taffybar-4.0.1/ 0000755 0000000 0000000 00000000000 07346545000 011503 5 ustar 00 0000000 0000000 taffybar-4.0.1/CHANGELOG.md 0000644 0000000 0000000 00000035034 07346545000 013321 0 ustar 00 0000000 0000000 # Unreleased
## Bug Fixes
* Gtk.widgetShowAll is run on the widget created by `cryptoPriceLabelWithIcon`,
so that it shows up by default.
# 4.0.0
## Breaking Changes
* `simpleTaffybar` now starts taffybar using `startTaffybar` instead of
`dyreTaffybar`. Use `simpleDyreTaffybar` to start taffybar with
`dyreTaffybar` as before.
* The `cssPath` fields in 'SimpleTaffyConfig' and 'TaffybarConfig' have been
renamed to `cssPaths` and have type `[FilePath]` instead of `Maybe Filepath`.
* The module `System.Taffybar.Widget.Decorators` has been removed. The
functions that were in that module can now be found in
`System.Taffybar.Widget.Util`.
* The `barHeight` property of `SimpleTaffyConfig` is now a `StrutSize`. This
means that in addition to specifying an exact pixel count for the height of
taffybar, it is also possible to specify a fraction of the screen that it
should occupy. See the docs for `StrutSize` for more details.
## New Features
* A new module `System.Taffybar.Widget.Crypto` that contains widgets that display
the prices of crypto assets with icons was added.
* `textBatteryNewLabelAction` provides a version of the text battery widget to
which a custom label updater function can be provided.
* The textual battery widget now applies classes according to its charge level
that can be used to style the battery text with css.
* A generalized interface to the text battery widget that accepts an arbitrary
update function is available at `textBatteryNewLabelAction`.
* New workspace widget builder `buildLabelOverlayController` that overlays the
workspace label on top of the the workspace icons.
* It is now possible to customize the player widgets of the MPRIS2 Widget by
using the new function `mpris2NewWithConfig`.
* Classes are added to the MPRIS2 Widget to indicate whether or not it has
visible player children.
* The default MPRIS2 player widget now sends the play pause message to the
relevant player when clicked.
* New `pollingGraphNewWithTooltip` that allows to specify a tooltip.
* New `networkGraphNewWith` that allows to configure a tooltip format, scaling
and network interfaces via function.
* New `showMemoryInfo` exposed from `MemoryMonitor` that can be used to format
tooltips.
* Swap variables are added to `MemoryMonitor`.
* Many types have `Default` instances.
* Window titles are shown on hover.
* Allow sorting workspace window icons by _NET_CLIENT_LIST_STACKING.
## Changes
* Graph labels are now overlayed on top of the graph instead of placed beside
them.
* MPRIS2 Widgets will remain visible when their players are in the paused state.
* `getSongInfo` now doesn't automatically return `Nothing` when `xesam:artist`
is missing. This makes the MPRIS2 Widget display in more situations than
before.
* Network graph will have a tooltip by default.
* The SNI Tray will respect `ItemIsMenu` property to handle mouse left click.
## Bug Fixes
* Center widgets will now properly expand vertically.
* Errors, including icon missing from theme errors, in workspace pixbuf getters
are now handled gracefully.
* A workaround to properly display the chrome icon in MPRIS was added.
# 3.3.0
## Bug Fixes
* Compatibility with newer versions of GHC.
## New Features
* A wttr.in widget was added.
* Make memoryAvailable action available inside the Text MemoryMonitor widget.
* The SNI Tray supports triggering Activate and SecondaryActivate on icons.
* Better formatting for Text MemoryMonitor Widget
# 3.2.2
## Bug Fixes
* Solve space leaks on `updateSamples` and `getDeviceUpDown` (#472).
* Prevent crash when using mpris2New and librsvg is not available (#478).
* Fixed compilation issues that appear when using ghc 8.8.
# 3.2.1
## Bug Fixes
* The workspaces widget now listens on the additional EWMH properties that it
needs to in order to properly update things when the active window changes.
This problem likely only emerged recently because xmonad has recently become
much more conservative about emitting change events (#454).
* The workspaces widget listens for changes to window geometry (similar to
above) (#456).
# 3.2.0
## New Features
* The Layout widget can now be styled with the css class "layout-label".
* A new polling label function `pollingLabelWithVariableDelay` that allows for
variable poll times was added.
* A new widget `System.Taffybar.Widget.SimpleCommandButton` was added.
* Taffybar now outputs colorized and annotated logs by default.
## Breaking Changes
* The file specified in the cssPath parameter in config is now used instead of,
rather than in addition to the default user config file.
* All parameters are now passed to `textClockNewWith` as part of the
ClockConfig it receives. A new mechanism for rounded variable polling should
allow the clock to always remain accurate (to the precision selected by the
user) without having a very high polling rate, thus reducing CPU usage.
* The polling label functions no longer accept a default text parameter.
## Miscellaneous
* Battery updates are only triggered when a more limited number of UPower
properties are changed. This can be customized by manually calling
`setupDisplayBatteryChanVar` as a hook.
## Bug Fixes
* Calendar pops up below bar without hiding any other widget #261.
* Avoid failing when parsing XDG Desktop files with unrecognized application
type, which previously resulted in "Prelude.read: no parse" #447.
* Use XDG data dir so that taffybar dbus toggling functions correctly when
taffybar is installed in a location that is not writable by the user. This is
the case with nix when it is installed in the nix store #452.
# 3.1.2
## Updates
* Weather now uses new uris and https (Kirill Zaborsky)
* Bump the version of gi-gdkpixbuf, this fixes nixpkgs compilation
# 3.1.0
## New Features
* A new module Chrome which makes it so that Workspaces can display the
favicons of the website that the chrome window is currently visiting.
# 3.0.0
## Breaking Changes
* Taffybar has replaced gtk2hs with gi-gtk everywhere. All widgets must now be
created with gi-gtk.
# 2.0.0
## Breaking Changes
* An entirely new config system has been put in place. TaffybarConfig now lives
in System.Taffybar.Context, but for most users, System.Taffybar.SimpleConfig
is the configuration interface that should be used.
* The main entry point to taffybar is now dyreTaffybar instead of
defaultTaffybar.
* All widget constructors provided to both config systems must now be of type
`TaffyIO Gtk.Widget`. If you have an existing `IO Gtk.Widget` you can convert it
using liftIO. All widgets provided by taffybar are now of type
`MonadIO m => m Gtk.Widget`, or specialized to `TaffyIO Gtk.Widgets`.
* The `graphBackgroundColor` and `graphBorderColor` fields are now RGBA
quadruples instead of RGB triples.
* Module removals:
- WorkspaceSwitcher: Workspaces is much more abstract and makes this widget
redundant.
- Pager: The Context module solves the problem that Pager solved in a much
more general way. It also makes it so that the user doesn't even need to
know about the Pager component at all.
- TaffyPager: Since you no longer need to explicitly initialize a Pager, it's
not really very hard to simply add the (Workspaces, Layout, Windows) triple
to your config any more.
- XMonadLog: This module has long been deprecated
* Module moves:
- Everything in System.Information has been moved to
System.Information.Taffybar
- All Widgets that were found in System.Taffybar have been moved to
System.Taffybar.Widget
- The helper widgets that were previously located in System.Taffybar.Widgets
have been moved to System.Taffybar.Widget.Generic
* Module renames:
- WorkspaceHUD -> Workspaces
- WindowSwitcher -> Windows
- LayoutSwitcher -> Layout
- ToggleMonitors -> DBus.Toggle
* Module deprecations:
- System.Taffybar.Widget.Systray (Use SNITray instead)
- System.Taffybar.Widget.NetMonitor (Use
System.Taffybar.Widget.Text.NetworkMonitor instead)
* Many widgets have subtle interface changes that may break existing configurations.
## New Features
* Widgets can now be placed in the center of taffybar with the `centerWidgets`
configuration parameter.
* taffybar is now transparent by default, but you will need to use a compositor
for transparency to work. https://github.com/chjj/compton is recommended. If
you do not want a transparent taffybar set a background color on the class
`TaffyBox` in taffybar.css.
* StatusNotifierItem support has been added to taffybar in the SNITray module.
* Monitor configuration changes are handled automatically. Unfortunately the
bar must be completely recreated when this happens.
* New network monitor widgets `System.Taffybar.Widget.Text.NetworkMonitor`
and `System.Taffybar.Widget.NetworkGraph` were added.
* All widgets are now exported in `System.Taffybar.Widget`, which should
eliminate the need to import widgets explicitly.
# 1.0.2
## Bug Fixes
* Fix long standing memory leak that was caused by a failure to free memory
allocated for gtk pixbufs.
* Widgets unregister from X11 event listening.
# 1.0.0
## Breaking Changes
* Migrate from Gtk2 to Gtk3, which replaces rc theming with css theming (Ivan Malison)
## New Features
* Support for taffybar on multiple monitors (Ivan Malison)
* D-Bus toggling of taffybar per monitor (Ivan Malison)
* A new workspace switcher widget called WorkspaceHUD (Ivan Malison)
* Support for multiple batteries via ``batteryContextsNew`` (Edd Steel)
* Add support for IO actions to configure vertical bar widgets
* Images in WorkspaceSwitcher - images are taken from EWMH via \_NET\_WM_ICON (Elliot Wolk)
* Preliminary support for i3wm (Saksham Sharma)
* Support for multiple network interfaces in NetMonitor (Robert Klotzner)
* Add a pager config field that configures the construction of window switcher titles (Ivan Malison)
* Quick start script for installing from git with stack (Ivan Malison)
* Add a volume widget (Nick Hu and Abdul Sattar)
* Add available memory field to MemoryInfo (Will Price)
* The freedesktop.org notifications widget now allows for notifications to
never expire and can handle multiple notifications at once. In particular the
default formatter now shows the number of pending notifications (Daniel
Oliveira)
* Battery bar is more informative (Samshak Sharma)
* Network monitor speeds are auto formatted to use the most appropriate units (TeXitoi)
* A new freedesktop.org menu widget (u11gh)
...and many smaller tweaks.
## Bug Fixes
* Fixes for outdated weather information sources
* Various styling fixes in the gtkrc code
* Share a single X11Connection between all components to fix the `user error
(openDisplay)` error (Ivan Malison)
* Call initThreads at startup. This fixes ```taffybar-linux-x86_64:
xcb_io.c:259: poll_for_event: Assertion `!xcb_xlib_threads_sequence_lost'
failed.``` (Ivan Malison)
* Add an eventBox to window switcher to allow setting its background (Ivan Malison)
* #105 Prevent taffybar from crashing when two windows are closed
simultaneously, or when taffybar otherwise requests data about a window that
no longer exists.
# 0.4.6
* Fix a longstanding bug in loading .rc files (Peder Stray)
* Add support for scrolling in the workspace switcher (Saksham Sharma)
* Improve default formatting of empty workspaces in the pager (Saksham Sharma)
* Relax gtk version bounds
# 0.4.5
* GHC 7.10 compat
# 0.4.4
* Fix compilation with gtk 0.13.1
# 0.4.3
* Try again to fix the network dependency
# 0.4.2
* Expand the version range for time
* Depend on network-uri instead of network
# 0.4.1
* Make the clock react to time zone changes
# 0.4.0
## Features
* Resize the bar when the screen configuration changes (Robert Helgesson)
* Support bypassing `dyre` by exposing `taffybarMain` (Christian Hoener zu Siederdissen)
* Textual CPU and memory monitors (Zakhar Voit)
* A new window switcher menu in the pager (José Alfredo Romero L)
* Dynamic workspace support in the workspace switcher (Nick Hu)
* More configurable network monitor (Arseniy Seroka)
* New widget: text-based command runner (Arseniy Seroka)
* The Graph widget supports lines graphs (via graphDataStyles) (Joachim Breitner)
* Compile with gtk2hs 0.13
## Bug Fixes
* Reduce wakeups by tweaking the default GHC RTS options (Joachim Breitner)
* UTF8 fixes (Nathan Maxson)
* Various fixes to EWMH support (José Alfredo Romero L)
## Deprecations
The `XMonadLog` module is deprecated. This module let taffybar display XMonad desktop information through a dbus connection. The EWMH desktop support by José Alfredo Romero L is better in every way, so that (through TaffyPager) is the recommended replacement. Upgrading should be straightforward.
# 0.3.0:
* A new pager (System.Taffybar.TaffyPager) from José A. Romero L. This pager is a drop-in replacement for the dbus-based XMonadLog widget. It communicates via X atoms and EWMH like a real pager. It even supports changing workspaces by clicking on them. I recommend this over the old widget.
* Added an MPRIS2 widget (contributed by Igor Babuschkin)
* Ported to use the newer merged dbus library instead of dbus-client/dbus-core (contributed by CJ van den Berg)
* Finally have the calendar widget pop up over the date/time widget (contributed by José A. Romero)
* GHC 7.6 compatibility
* Vertical bars can now have dynamic background colors (suggested by Elliot Wolk)
* Bug fixes
# 0.2.1:
* More robust strut handling for multiple monitors of different sizes (contributed by Morgan Gibson)
* New widgets from José A. Romero (network monitor, fs monitor, another CPU monitor)
* Allow the bar widget to grow vertically (also contributed by José A. Romero)
# 0.2.0:
* Add some more flexible formatting options for the XMonadLog widget (contributed by cnervi).
* Make the PollingLabel more robust with an exception handler for IOExceptions
* Added more documentation for a few widgets
# 0.1.3:
* Depend on gtk 0.12.1+ to be able to build under ghc 7.2
* Fix the background colors in the calendar so that it follows the GTK theme instead of the bar-specific color settings
* Fix the display of non-ASCII window titles in the XMonad log applet (assuming you use the dbusLog function)
* Add a horrible hack to force the bar to not resize to be larger than the screen due to notifications or long window titles
# 0.1.2:
* Readable widget for freedesktop notifications
* Fixed a few potential deadlocks on startup
* Use the GTK+ rc-file styling system for colors instead of hard coding them
taffybar-4.0.1/LICENSE 0000644 0000000 0000000 00000003015 07346545000 012507 0 ustar 00 0000000 0000000 Copyright (c) (2011-2019), Tristan Ravitch, Ivan Malison
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:
* Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
* Redistributions in binary form must reproduce the above
copyright notice, this list of conditions and the following
disclaimer in the documentation and/or other materials provided
with the distribution.
* Neither the name of Tristan Ravitch nor the names of other
contributors may be used to endorse or promote products derived
from this software without specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
taffybar-4.0.1/README.md 0000644 0000000 0000000 00000021212 07346545000 012760 0 ustar 00 0000000 0000000 # Taffybar
[](https://github.com/taffybar/taffybar/actions/workflows/nix.yml) [](https://hackage.haskell.org/package/taffybar) [](https://github.com/taffybar/taffybar/compare/latest-release...master) [](http://stackage.org/lts/package/taffybar) [](http://stackage.org/nightly/package/taffybar) [](https://github.com/taffybar/taffybar/labels/help%20wanted) [](https://matrix.to/#/#taffybar:matrix.org) [](https://gitter.im/taffybar/Lobby) [](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
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.
Before Installing
-----------------
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.
### 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. 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.
### 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.
### Cabal
Simply run `cabal new-install` to install the binary.
### Stack
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)
### Nix
You will need to add default.nix file to your package. See [this
example](https://github.com/taffybar/taffybar/blob/master/example/default.nix)
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.
#### Overlay
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).
Configuration
-------------
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.
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).
FAQ
---
For the time being, taffybar's frequently asked questions page lives in [this
github issue](https://github.com/taffybar/taffybar/issues/332).
Contributing
------------
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:
[](https://github.com/taffybar/taffybar/labels/help%20wanted)
[](https://github.com/taffybar/taffybar/labels/easy)
taffybar-4.0.1/Setup.hs 0000644 0000000 0000000 00000000056 07346545000 013140 0 ustar 00 0000000 0000000 import Distribution.Simple
main = defaultMain
taffybar-4.0.1/app/ 0000755 0000000 0000000 00000000000 07346545000 012263 5 ustar 00 0000000 0000000 taffybar-4.0.1/app/Main.hs 0000644 0000000 0000000 00000003121 07346545000 013500 0 ustar 00 0000000 0000000 {-# OPTIONS_GHC -fno-warn-unused-imports #-}
-- | This is just a stub executable that uses dyre to read the config file and
-- recompile itself.
module Main ( main ) where
import Data.Default (def)
import Data.Semigroup ((<>))
import Data.Version
import Options.Applicative
import System.Directory
import System.Log.Logger
import System.Taffybar
import System.Taffybar.Context
import System.Taffybar.Example
import Text.Printf
import Paths_taffybar (version)
logP :: Parser Priority
logP =
option auto
( long "log-level"
<> short 'l'
<> help "Set the log level"
<> metavar "LEVEL"
<> value WARNING
)
versionOption :: Parser (a -> a)
versionOption = infoOption
(printf "taffybar %s" $ showVersion version)
( long "version"
<> help "Show the version number of taffybar"
)
main :: IO ()
main = do
logLevel <- execParser $ info (helper <*> versionOption <*> logP)
( fullDesc
<> progDesc "Start taffybar, recompiling if necessary"
)
logger <- getLogger "System.Taffybar"
saveGlobalLogger $ setLevel logLevel logger
taffyFilepath <- getTaffyFile "taffybar.hs"
configurationExists <- doesFileExist taffyFilepath
if configurationExists
-- XXX: The configuration record here does not get used, this just calls in to dyre.
then dyreTaffybar def
else do
logM "System.Taffybar" WARNING $
( printf "No taffybar configuration file found at %s." taffyFilepath
++ " Starting with example configuration."
)
startTaffybar exampleTaffybarConfig
taffybar-4.0.1/dbus-xml/ 0000755 0000000 0000000 00000000000 07346545000 013236 5 ustar 00 0000000 0000000 taffybar-4.0.1/dbus-xml/org.freedesktop.UPower.Device.xml 0000644 0000000 0000000 00000004503 07346545000 021501 0 ustar 00 0000000 0000000
taffybar-4.0.1/dbus-xml/org.freedesktop.UPower.xml 0000644 0000000 0000000 00000001735 07346545000 020307 0 ustar 00 0000000 0000000
taffybar-4.0.1/dbus-xml/org.mpris.MediaPlayer2.Player.xml 0000644 0000000 0000000 00000002173 07346545000 021413 0 ustar 00 0000000 0000000
taffybar-4.0.1/dbus-xml/org.mpris.MediaPlayer2.xml 0000644 0000000 0000000 00000000536 07346545000 020161 0 ustar 00 0000000 0000000
taffybar-4.0.1/icons/ 0000755 0000000 0000000 00000000000 07346545000 012616 5 ustar 00 0000000 0000000 taffybar-4.0.1/icons/play.svg 0000644 0000000 0000000 00000001732 07346545000 014307 0 ustar 00 0000000 0000000
taffybar-4.0.1/src/System/ 0000755 0000000 0000000 00000000000 07346545000 013556 5 ustar 00 0000000 0000000 taffybar-4.0.1/src/System/Taffybar.hs 0000644 0000000 0000000 00000021622 07346545000 015653 0 ustar 00 0000000 0000000 {-# OPTIONS_GHC -fno-warn-missing-signatures #-}
-----------------------------------------------------------------------------
-- |
-- Module : System.Taffybar
-- Copyright : (c) Ivan A. Malison
-- License : BSD3-style (see LICENSE)
--
-- Maintainer : Ivan A. Malison
-- Stability : unstable
-- Portability : unportable
-----------------------------------------------------------------------------
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
-- 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
-- |
-- 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
-- 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
-- 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
-- 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
-- set of widgets provided by the library, because custom code and widgets can
-- be provided to taffybar for instantiation and execution.
--
-- The following code snippet is a simple example of what a taffybar
-- configuration might look like (also see "System.Taffybar.Example"):
--
-- > {-# LANGUAGE OverloadedStrings #-}
-- > import Data.Default (def)
-- > import System.Taffybar
-- > import System.Taffybar.Information.CPU
-- > import System.Taffybar.SimpleConfig
-- > import System.Taffybar.Widget
-- > import System.Taffybar.Widget.Generic.Graph
-- > import System.Taffybar.Widget.Generic.PollingGraph
-- >
-- > cpuCallback = do
-- > (_, systemLoad, totalLoad) <- cpuLoad
-- > return [ totalLoad, systemLoad ]
-- >
-- > main = do
-- > let cpuCfg = def
-- > { graphDataColors = [ (0, 1, 0, 1), (1, 0, 1, 0.5)]
-- > , graphLabel = Just "cpu"
-- > }
-- > clock = textClockNewWith def
-- > cpu = pollingGraphNew cpuCfg 0.5 cpuCallback
-- > workspaces = workspacesNew def
-- > simpleConfig = def
-- > { startWidgets = [ workspaces ]
-- > , endWidgets = [ sniTrayNew, clock, cpu ]
-- > }
-- > simpleTaffybar simpleConfig
--
-- This configuration creates a bar with four widgets. On the left is a widget
-- that shows information about the workspace configuration. The rightmost
-- widget is the system tray, with a clock and then a CPU graph.
--
-- The CPU widget plots two graphs on the same widget: total CPU use in green
-- 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
-- performing some GTK initialization.
--
-- * Taffybar and DBus
--
-- | Taffybar has a strict dependency on dbus, so you must ensure that it 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 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
-- 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
--
-- * System tray compatability
--
-- | "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.
--
-- Additionally, this module does not handle recognising new tray applets.
-- Instead it is necessary to run status-notifier-watcher from the
-- [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
-- 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
, dyreTaffybarMain
, getTaffyFile
, startTaffybar
, taffybarDyreParams
) where
import qualified Config.Dyre as Dyre
import qualified Config.Dyre.Params as Dyre
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 System.Directory
import System.Environment.XDG.BaseDir ( getUserConfigFile )
import System.Exit ( exitFailure )
import System.FilePath ( () )
import qualified System.IO as IO
import System.Log.Logger
import System.Taffybar.Context
import System.Taffybar.Hooks
import Paths_taffybar ( getDataDir )
-- | The parameters that are passed to Dyre when taffybar is invoked with
-- 'dyreTaffybar'.
taffybarDyreParams =
(Dyre.newParams "taffybar" dyreTaffybarMain showError)
{ Dyre.ghcOpts = ["-threaded", "-rtsopts"]
, 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.
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.
dyreTaffybarMain :: TaffybarConfig -> IO ()
dyreTaffybarMain cfg =
case errorMsg cfg of
Nothing -> startTaffybar cfg
Just err -> do
IO.hPutStrLn IO.stderr ("Error: " ++ err)
exitFailure
getDataFile :: String -> IO FilePath
getDataFile name = do
dataDir <- getDataDir
return (dataDir name)
startCSS :: [FilePath] -> IO Gtk.CssProvider
startCSS cssFilePaths = do
-- Override the default GTK theme path settings. This causes the
-- bar (by design) to ignore the real GTK theme and just use the
-- provided minimal theme to set the background and text colors.
-- Users can override this default.
taffybarProvider <- Gtk.cssProviderNew
let loadIfExists filePath =
doesFileExist filePath >>=
flip when (Gtk.cssProviderLoadFromPath taffybarProvider (T.pack filePath))
mapM_ loadIfExists cssFilePaths
Just scr <- Gdk.screenGetDefault
Gtk.styleContextAddProviderForScreen scr taffybarProvider 800
return taffybarProvider
getTaffyFile :: String -> IO FilePath
getTaffyFile = getUserConfigFile "taffybar"
getDefaultCSSPaths :: IO [FilePath]
getDefaultCSSPaths = do
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
-- 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
-- better) to use this function.
startTaffybar :: TaffybarConfig -> IO ()
startTaffybar config = do
updateGlobalLogger "" removeHandler
setTaffyLogFormatter "System.Taffybar"
setTaffyLogFormatter "StatusNotifier"
_ <- initThreads
_ <- Gtk.init Nothing
GIThreading.setCurrentThreadAsGUIThread
defaultCSS <- getDataFile "taffybar.css"
cssPathsToLoad <-
if null $ cssPaths config
then getDefaultCSSPaths
else return $ cssPaths config
_ <- startCSS $ defaultCSS:cssPathsToLoad
_ <- buildContext config
Gtk.main
return ()
taffybar-4.0.1/src/System/Taffybar/ 0000755 0000000 0000000 00000000000 07346545000 015314 5 ustar 00 0000000 0000000 taffybar-4.0.1/src/System/Taffybar/Auth.hs 0000644 0000000 0000000 00000001510 07346545000 016546 0 ustar 00 0000000 0000000 {-# LANGUAGE OverloadedStrings #-}
module System.Taffybar.Auth where
import Control.Arrow
import Control.Monad.IO.Class
import Data.Maybe
import System.Taffybar.Util
import Text.Regex
fieldRegex :: Regex
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)
taffybar-4.0.1/src/System/Taffybar/Context.hs 0000644 0000000 0000000 00000043752 07346545000 017307 0 ustar 00 0000000 0000000 {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MonoLocalBinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ImpredicativeTypes #-}
-----------------------------------------------------------------------------
-- |
-- Module : System.Taffybar.Context
-- Copyright : (c) Ivan A. Malison
-- License : BSD3-style (see LICENSE)
--
-- Maintainer : Ivan A. Malison
-- Stability : unstable
-- Portability : unportable
--
-- The "System.Taffybar.Context" module provides the core functionality of the
-- taffybar library. It gets its name from the 'Context' record, which stores
-- runtime information and objects, which are used by many of the widgets that
-- taffybar provides. 'Context' is typically accessed through the 'Reader'
-- interface of 'TaffyIO'.
-----------------------------------------------------------------------------
module System.Taffybar.Context
( Context(..)
, TaffybarConfig(..)
, Taffy
, TaffyIO
, BarConfig(..)
, BarConfigGetter
, appendHook
, buildContext
, buildEmptyContext
, defaultTaffybarConfig
, getState
, getStateDefault
, putState
, forceRefreshTaffyWindows
, refreshTaffyWindows
, runX11
, runX11Def
, subscribeToAll
, subscribeToPropertyEvents
, taffyFork
, unsubscribe
) where
import Control.Arrow ((&&&))
import Control.Concurrent (forkIO)
import qualified Control.Concurrent.MVar as MV
import Control.Exception.Enclosed (catchAny)
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.Class
import Control.Monad.Trans.Maybe
import Control.Monad.Trans.Reader
import qualified DBus.Client as DBus
import Data.Data
import Data.Default (Default(..))
import Data.GI.Base.ManagedPtr (unsafeCastTo)
import Data.Int
import Data.List
import qualified Data.Map as M
import qualified Data.Text as T
import Data.Tuple.Select
import Data.Tuple.Sequence
import Data.Unique
import qualified GI.Gdk
import qualified GI.GdkX11 as GdkX11
import GI.GdkX11.Objects.X11Window
import qualified GI.Gtk as Gtk
import Graphics.UI.GIGtkStrut
import StatusNotifier.TransparentWindow
import System.Log.Logger
import System.Taffybar.Information.SafeX11
import System.Taffybar.Information.X11DesktopInfo
import System.Taffybar.Util
import System.Taffybar.Widget.Util
import Text.Printf
import Unsafe.Coerce
logIO :: System.Log.Logger.Priority -> String -> IO ()
logIO = logM "System.Taffybar.Context"
logC :: MonadIO m => System.Log.Logger.Priority -> String -> m ()
logC p = liftIO . logIO p
-- | 'Taffy' is a monad transformer that provides 'Reader' 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 TaffyIO v = ReaderT Context IO v
type Listener = Event -> Taffy IO ()
type SubscriptionList = [(Unique, Listener)]
data Value = forall t. Typeable t => Value t
fromValue :: forall t. Typeable t => Value -> Maybe t
fromValue (Value v) =
if typeOf v == typeRep (Proxy :: Proxy t) then
Just $ unsafeCoerce v
else
Nothing
-- | 'BarConfig' specifies the configuration for a single taffybar window.
data BarConfig = BarConfig
{
-- | The strut configuration to use for the bar
strutConfig :: StrutConfig
-- | The amount of spacing in pixels between bar widgets
, widgetSpacing :: Int32
-- | Constructors for widgets that should be placed at the beginning of the bar.
, startWidgets :: [TaffyIO Gtk.Widget]
-- | Constructors for widgets that should be placed in the center of the bar.
, centerWidgets :: [TaffyIO Gtk.Widget]
-- | Constructors for widgets that should be placed at the end of the bar.
, endWidgets :: [TaffyIO Gtk.Widget]
-- | A unique identifier for the bar, that can be used e.g. when toggling.
, barId :: Unique
}
instance Eq BarConfig where
a == b = barId a == barId b
type BarConfigGetter = TaffyIO [BarConfig]
-- | 'TaffybarConfig' provides an advanced interface for configuring taffybar.
-- Through the 'getBarConfigsParam', it is possible to specify different
-- taffybar configurations depending on the number of monitors present, and even
-- to specify different taffybar configurations for each monitor.
data TaffybarConfig = TaffybarConfig
{
-- | An optional dbus client to use.
dbusClientParam :: Maybe DBus.Client
-- | Hooks that should be executed at taffybar startup.
, startupHook :: TaffyIO ()
-- | A 'TaffyIO' action that returns a list of 'BarConfig' where each element
-- describes a taffybar window that should be spawned.
, getBarConfigsParam :: BarConfigGetter
-- | A list of 'FilePath' each of which should be loaded as css files at
-- startup.
, cssPaths :: [FilePath]
-- | A field used (only) by dyre to provide an error message.
, errorMsg :: Maybe String
}
-- | Append the provided 'TaffyIO' hook to the 'startupHook' of the given
-- 'TaffybarConfig'.
appendHook :: TaffyIO () -> TaffybarConfig -> TaffybarConfig
appendHook hook config = config
{ startupHook = startupHook config >> hook }
-- | Default values for a 'TaffybarConfig'. Not usuable without at least
-- properly setting 'getBarConfigsParam'.
defaultTaffybarConfig :: TaffybarConfig
defaultTaffybarConfig = TaffybarConfig
{ dbusClientParam = Nothing
, startupHook = return ()
, getBarConfigsParam = return []
, cssPaths = []
, errorMsg = Nothing
}
instance Default TaffybarConfig where
def = defaultTaffybarConfig
-- | A "Context" value holds all of the state associated with a single running
-- instance of taffybar. It is typically accessed from a widget constructor
-- through the "TaffyIO" monad transformer stack.
data Context = Context
{
-- | The X11Context that will be used to service X11Property requests.
x11ContextVar :: MV.MVar X11Context
-- | The handlers which will be evaluated against incoming X11 events.
, listeners :: MV.MVar SubscriptionList
-- | A collection of miscellaneous pieces of state which are keyed by their
-- types. Most new pieces of state should go here, rather than in a new field
-- in 'Context'. State stored here is typically accessed through
-- 'getStateDefault'.
, contextState :: MV.MVar (M.Map TypeRep Value)
-- | Used to track the windows that taffybar is currently controlling, and
-- which 'BarConfig' objects they are associated with.
, existingWindows :: MV.MVar [(BarConfig, Gtk.Window)]
-- | The shared user session 'DBus.Client'.
, sessionDBusClient :: DBus.Client
-- | The shared system session 'DBus.Client'.
, systemDBusClient :: DBus.Client
-- | The action that will be evaluated to get the bar configs associated with
-- each active monitor taffybar should run on.
, getBarConfigs :: BarConfigGetter
-- | Populated with the BarConfig that resulted in the creation of a given
-- widget, when its constructor is called. This lets widgets access thing like
-- who their neighbors are. Note that the value of 'contextBarConfig' is
-- different for widgets belonging to bar windows on different monitors.
, contextBarConfig :: Maybe BarConfig
}
-- | Build the "Context" for a taffybar process.
buildContext :: TaffybarConfig -> IO Context
buildContext TaffybarConfig
{ dbusClientParam = maybeDBus
, getBarConfigsParam = barConfigGetter
, startupHook = startup
} = do
logIO DEBUG "Building context"
dbusC <- maybe DBus.connectSession return maybeDBus
sDBusC <- DBus.connectSystem
_ <- DBus.requestName dbusC "org.taffybar.Bar"
[DBus.nameAllowReplacement, DBus.nameReplaceExisting]
listenersVar <- MV.newMVar []
state <- MV.newMVar M.empty
x11Context <- getDefaultCtx >>= MV.newMVar
windowsVar <- MV.newMVar []
let context = Context
{ x11ContextVar = x11Context
, listeners = listenersVar
, contextState = state
, sessionDBusClient = dbusC
, systemDBusClient = sDBusC
, getBarConfigs = barConfigGetter
, existingWindows = windowsVar
, contextBarConfig = Nothing
}
_ <- runMaybeT $ MaybeT GI.Gdk.displayGetDefault >>=
(lift . GI.Gdk.displayGetDefaultScreen) >>=
(lift . flip GI.Gdk.afterScreenMonitorsChanged
-- XXX: We have to do a force refresh here because there is no
-- way to reliably move windows, since the window manager can do
-- whatever it pleases.
(runReaderT forceRefreshTaffyWindows context))
flip runReaderT context $ do
logC DEBUG "Starting X11 Handler"
startX11EventHandler
logC DEBUG "Running startup hook"
startup
logC DEBUG "Queing build windows command"
refreshTaffyWindows
logIO DEBUG "Context build finished"
return context
-- | Build an empty taffybar context. This function is mostly useful for
-- invoking functions that yield 'TaffyIO' values in a testing setting (e.g. in
-- a repl).
buildEmptyContext :: IO Context
buildEmptyContext = buildContext def
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
window <- Gtk.windowNew Gtk.WindowTypeToplevel
box <- Gtk.boxNew Gtk.OrientationHorizontal $ fromIntegral $
widgetSpacing barConfig
_ <- widgetSetClassGI box "taffy-box"
centerBox <- Gtk.boxNew Gtk.OrientationHorizontal $
fromIntegral $ widgetSpacing barConfig
_ <- widgetSetClassGI centerBox "center-box"
Gtk.widgetSetVexpand centerBox True
Gtk.setWidgetValign centerBox Gtk.AlignFill
Gtk.setWidgetHalign centerBox Gtk.AlignCenter
Gtk.boxSetCenterWidget box (Just centerBox)
setupStrutWindow (strutConfig barConfig) window
Gtk.containerAdd window box
_ <- widgetSetClassGI window "taffy-window"
let addWidgetWith widgetAdd (count, buildWidget) =
runReaderT buildWidget thisContext >>= widgetAdd count
addToStart count widget = do
_ <- widgetSetClassGI widget $ T.pack $ printf "left-%d" (count :: Int)
Gtk.boxPackStart box widget False False 0
addToEnd count widget = do
_ <- widgetSetClassGI widget $ T.pack $ printf "right-%d" (count :: Int)
Gtk.boxPackEnd box widget False False 0
addToCenter count widget = do
_ <- widgetSetClassGI widget $ T.pack $ printf "center-%d" (count :: Int)
Gtk.boxPackStart centerBox widget False False 0
logIO DEBUG "Building start widgets"
mapM_ (addWidgetWith addToStart) $ zip [1..] (startWidgets barConfig)
logIO DEBUG "Building center widgets"
mapM_ (addWidgetWith addToCenter) $ zip [1..] (centerWidgets barConfig)
logIO DEBUG "Building end widgets"
mapM_ (addWidgetWith addToEnd) $ zip [1..] (endWidgets barConfig)
makeWindowTransparent window
logIO DEBUG "Showing window"
Gtk.widgetShow window
Gtk.widgetShow box
Gtk.widgetShow centerBox
runX11Context context () $ void $ runMaybeT $ do
gdkWindow <- MaybeT $ Gtk.widgetGetWindow window
xid <- GdkX11.x11WindowGetXid =<< liftIO (unsafeCastTo X11Window gdkWindow)
logC DEBUG $ printf "Lowering X11 window %s" $ show xid
lift $ doLowerWindow (fromIntegral xid)
return window
-- | Use the "barConfigGetter" field of "Context" to get the set of taffybar
-- 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
logC DEBUG "Refreshing windows"
ctx <- ask
windowsVar <- asks existingWindows
let rebuildWindows currentWindows = flip runReaderT ctx $
do
barConfigs <- join $ asks getBarConfigs
let currentConfigs = map sel1 currentWindows
newConfs = filter (`notElem` currentConfigs) barConfigs
(remainingWindows, removedWindows) =
partition ((`elem` barConfigs) . sel1) currentWindows
setPropertiesFromPair (barConf, window) =
setupStrutWindow (strutConfig barConf) window
newWindowPairs <- lift $ do
logIO DEBUG $ printf "removedWindows: %s" $
show $ map (strutConfig . sel1) removedWindows
logIO DEBUG $ printf "remainingWindows: %s" $
show $ map (strutConfig . sel1) remainingWindows
logIO DEBUG $ printf "newWindows: %s" $
show $ map strutConfig newConfs
logIO DEBUG $ printf "barConfigs: %s" $
show $ map strutConfig barConfigs
logIO DEBUG "Removing windows"
mapM_ (Gtk.widgetDestroy . sel2) removedWindows
-- TODO: This should actually use the config that is provided from
-- getBarConfigs so that the strut properties of the window can be
-- altered.
logIO DEBUG "Updating strut properties for existing windows"
mapM_ setPropertiesFromPair remainingWindows
logIO DEBUG "Constructing new windows"
mapM (sequenceT . ((return :: a -> IO a) &&& buildBarWindow ctx))
newConfs
return $ newWindowPairs ++ remainingWindows
lift $ MV.modifyMVar_ windowsVar rebuildWindows
logC DEBUG "Finished refreshing windows"
return ()
-- | 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 []
asksContextVar :: (r -> MV.MVar b) -> ReaderT r IO b
asksContextVar getter = asks getter >>= lift . MV.readMVar
-- | Run a function needing an X11 connection in 'TaffyIO'.
runX11 :: X11Property a -> TaffyIO a
runX11 action =
asksContextVar x11ContextVar >>= lift . runReaderT action
-- | Use 'runX11' together with 'postX11RequestSyncProp' on the provided
-- property. Return the provided default if 'Nothing' is returned
-- 'postX11RequestSyncProp'.
runX11Def :: a -> X11Property a -> TaffyIO a
runX11Def dflt prop = runX11 $ postX11RequestSyncProp prop dflt
runX11Context :: MonadIO m => Context -> a -> X11Property a -> m a
runX11Context context dflt prop =
liftIO $ runReaderT (runX11Def dflt prop) context
-- | Get a state value by type from the 'contextState' field of 'Context'.
getState :: forall t. Typeable t => Taffy IO (Maybe t)
getState = do
stateMap <- asksContextVar contextState
let maybeValue = M.lookup (typeRep (Proxy :: Proxy t)) stateMap
return $ maybeValue >>= fromValue
-- | Like "putState", but avoids aquiring a lock if the value is already in the
-- map.
getStateDefault :: Typeable t => Taffy IO t -> Taffy IO t
getStateDefault defaultGetter =
getState >>= maybe (putState defaultGetter) return
-- | Get a value of the type returned by the provided action from the the
-- current taffybar state, unless the state does not exist, in which case the
-- action will be called to populate the state map.
putState :: forall t. Typeable t => Taffy IO t -> Taffy IO t
putState getValue = do
contextVar <- asks contextState
ctx <- ask
lift $ MV.modifyMVar contextVar $ \contextStateMap ->
let theType = typeRep (Proxy :: Proxy t)
currentValue = M.lookup theType contextStateMap
insertAndReturn value =
(M.insert theType (Value value) contextStateMap, value)
in flip runReaderT ctx $ maybe
(insertAndReturn <$> getValue)
(return . (contextStateMap,))
(currentValue >>= fromValue)
-- | A version of "forkIO" in "TaffyIO".
taffyFork :: ReaderT r IO () -> ReaderT r IO ()
taffyFork = void . liftReader forkIO
startX11EventHandler :: Taffy IO ()
startX11EventHandler = taffyFork $ do
c <- ask
-- XXX: The event loop needs its own X11Context to separately handle
-- communications from the X server. We deliberately avoid using the context
-- from x11ContextVar here.
lift $ withDefaultCtx $ eventLoop
(\e -> runReaderT (handleX11Event e) c)
-- | Remove the listener associated with the provided "Unique" from the
-- collection of listeners.
unsubscribe :: Unique -> Taffy IO ()
unsubscribe identifier = do
listenersVar <- asks listeners
lift $ MV.modifyMVar_ listenersVar $ return . filter ((== identifier) . fst)
-- | Subscribe to all incoming events on the X11 event loop. The returned
-- "Unique" value can be used to unregister the listener using "unsuscribe".
subscribeToAll :: Listener -> Taffy IO Unique
subscribeToAll listener = do
identifier <- lift newUnique
listenersVar <- asks listeners
let
-- XXX: This type annotation probably has something to do with the warnings
-- that occur without MonoLocalBinds, but it still seems to be necessary
addListener :: SubscriptionList -> SubscriptionList
addListener = ((identifier, listener):)
lift $ MV.modifyMVar_ listenersVar (return . addListener)
return identifier
-- | Subscribe to X11 "PropertyEvent"s where the property changed is in the
-- provided list.
subscribeToPropertyEvents :: [String] -> Listener -> Taffy IO Unique
subscribeToPropertyEvents eventNames listener = do
eventAtoms <- mapM (runX11 . getAtom) eventNames
let filteredListener event@PropertyEvent { ev_atom = atom } =
when (atom `elem` eventAtoms) $
catchAny (listener event) (const $ return ())
filteredListener _ = return ()
subscribeToAll filteredListener
handleX11Event :: Event -> Taffy IO ()
handleX11Event event =
asksContextVar listeners >>= mapM_ applyListener
where applyListener :: (Unique, Listener) -> Taffy IO ()
applyListener (_, listener) = taffyFork $ listener event
taffybar-4.0.1/src/System/Taffybar/DBus.hs 0000644 0000000 0000000 00000001150 07346545000 016502 0 ustar 00 0000000 0000000 module System.Taffybar.DBus
( module System.Taffybar.DBus.Toggle
, appendHook
, startTaffyLogServer
, withLogServer
, withToggleServer
) where
import Control.Monad.Trans.Class
import Control.Monad.Trans.Reader
import System.Log.DBus.Server
import System.Taffybar.Context
import System.Taffybar.DBus.Toggle
startTaffyLogServer :: TaffyIO ()
startTaffyLogServer =
asks sessionDBusClient >>= lift . startLogServer
withLogServer :: TaffybarConfig -> TaffybarConfig
withLogServer = appendHook startTaffyLogServer
withToggleServer :: TaffybarConfig -> TaffybarConfig
withToggleServer = handleDBusToggles
taffybar-4.0.1/src/System/Taffybar/DBus/Client/ 0000755 0000000 0000000 00000000000 07346545000 017367 5 ustar 00 0000000 0000000 taffybar-4.0.1/src/System/Taffybar/DBus/Client/MPRIS2.hs 0000644 0000000 0000000 00000000762 07346545000 020704 0 ustar 00 0000000 0000000 {-# LANGUAGE TemplateHaskell #-}
module System.Taffybar.DBus.Client.MPRIS2 where
import System.Taffybar.DBus.Client.Util
import System.FilePath
import System.Taffybar.DBus.Client.Params
generateClientFromFile defaultRecordGenerationParams playerGenerationParams False $
"dbus-xml" "org.mpris.MediaPlayer2.xml"
generateClientFromFile defaultRecordGenerationParams playerGenerationParams False $
"dbus-xml" "org.mpris.MediaPlayer2.Player.xml"
taffybar-4.0.1/src/System/Taffybar/DBus/Client/Params.hs 0000644 0000000 0000000 00000003645 07346545000 021156 0 ustar 00 0000000 0000000 {-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE OverloadedStrings #-}
module System.Taffybar.DBus.Client.Params where
import DBus
import DBus.Generation
import Language.Haskell.TH
import System.Taffybar.DBus.Client.Util
playerGenerationParams :: GenerationParams
playerGenerationParams = defaultGenerationParams
{ genTakeSignalErrorHandler = True
, genObjectPath = Just "/org/mpris/MediaPlayer2"
}
-- | The base object path for the UPower interface
uPowerBaseObjectPath :: ObjectPath
uPowerBaseObjectPath = "/org/freedesktop/UPower"
-- | The name of the power daemon bus
uPowerBusName :: BusName
uPowerBusName = "org.freedesktop.UPower"
uPowerDeviceInterfaceName :: InterfaceName
uPowerDeviceInterfaceName = "org.freedesktop.UPower.Device"
uPowerGenerationParams :: GenerationParams
uPowerGenerationParams = defaultGenerationParams
{ genTakeSignalErrorHandler = True
, genBusName = Just uPowerBusName
}
data BatteryType
= BatteryTypeUnknown
| BatteryTypeLinePower
| BatteryTypeBatteryType
| BatteryTypeUps
| BatteryTypeMonitor
| BatteryTypeMouse
| BatteryTypeKeyboard
| BatteryTypePda
| BatteryTypePhone
deriving (Show, Ord, Eq, Enum)
data BatteryState
= BatteryStateUnknown
| BatteryStateCharging
| BatteryStateDischarging
| BatteryStateEmpty
| BatteryStateFullyCharged
| BatteryStatePendingCharge
| BatteryStatePendingDischarge
deriving (Show, Ord, Eq, Enum)
data BatteryTechnology
= BatteryTechnologyUnknown
| BatteryTechnologyLithiumIon
| BatteryTechnologyLithiumPolymer
| BatteryTechnologyLithiumIronPhosphate
| BatteryTechnologyLeadAcid
| BatteryTechnologyNickelCadmium
| BatteryTechnologyNickelMetalHydride
deriving (Show, Ord, Eq, Enum)
batteryTypeForName :: GetTypeForName
batteryTypeForName name = const $
case name of
"Type" -> yes ''BatteryType
"State" -> yes ''BatteryState
"Technology" -> yes ''BatteryTechnology
_ -> Nothing
where yes = Just . ConT
taffybar-4.0.1/src/System/Taffybar/DBus/Client/UPower.hs 0000644 0000000 0000000 00000001003 07346545000 021136 0 ustar 00 0000000 0000000 {-# LANGUAGE TemplateHaskell #-}
module System.Taffybar.DBus.Client.UPower where
import DBus.Generation
import System.FilePath
import System.Taffybar.DBus.Client.Params
import System.Taffybar.DBus.Client.Util
generateClientFromFile
defaultRecordGenerationParams { recordName = Just "UPowerInfo"
, recordPrefix = "upi"
}
uPowerGenerationParams { genObjectPath = Just uPowerBaseObjectPath }
False $
"dbus-xml" "org.freedesktop.UPower.xml"
taffybar-4.0.1/src/System/Taffybar/DBus/Client/UPowerDevice.hs 0000644 0000000 0000000 00000000677 07346545000 022276 0 ustar 00 0000000 0000000 {-# LANGUAGE TemplateHaskell #-}
module System.Taffybar.DBus.Client.UPowerDevice where
import System.FilePath
import System.Taffybar.DBus.Client.Params
import System.Taffybar.DBus.Client.Util
generateClientFromFile
defaultRecordGenerationParams
{ recordName = Just "BatteryInfo"
, recordPrefix = "battery"
, recordTypeForName = batteryTypeForName
}
uPowerGenerationParams
False $ "dbus-xml" "org.freedesktop.UPower.Device.xml"
taffybar-4.0.1/src/System/Taffybar/DBus/Client/Util.hs 0000644 0000000 0000000 00000006743 07346545000 020652 0 ustar 00 0000000 0000000 {-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
module System.Taffybar.DBus.Client.Util where
import Control.Applicative
import DBus.Generation
import qualified DBus.Internal.Types as T
import qualified DBus.Introspection as I
import qualified Data.Char as Char
import Data.Coerce
import Data.Maybe
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
data RecordGenerationParams = RecordGenerationParams
{ recordName :: Maybe String
, recordPrefix :: String
, recordTypeForName :: GetTypeForName
}
defaultRecordGenerationParams :: RecordGenerationParams
defaultRecordGenerationParams = RecordGenerationParams
{ recordName = Nothing
, recordPrefix = "_"
, recordTypeForName = const $ const Nothing
}
generateGetAllRecord
:: RecordGenerationParams
-> GenerationParams
-> I.Interface
-> Q [Dec]
generateGetAllRecord
RecordGenerationParams
{ recordName = recordNameString
, recordPrefix = prefix
, recordTypeForName = getTypeForName
}
GenerationParams { getTHType = getArgType }
I.Interface { I.interfaceName = interfaceName
, I.interfaceProperties = properties
} = do
let theRecordName =
maybe (mkName $ map Char.toUpper $ filter Char.isLetter $ coerce interfaceName)
mkName recordNameString
let getPairFromProperty I.Property
{ I.propertyName = propName
, I.propertyType = propType
} =
( mkName $ prefix ++ propName
, fromMaybe (getArgType propType) $ getTypeForName propName propType
)
getAllRecord =
buildDataFromNameTypePairs
theRecordName $ map getPairFromProperty properties
return $ getAllRecord:standaloneDeriveEqShow theRecordName
generateClientFromFile :: RecordGenerationParams -> GenerationParams -> Bool -> FilePath -> Q [Dec]
generateClientFromFile recordGenerationParams params useObjectPath filepath = do
object <- getIntrospectionObjectFromFile filepath "/"
let interface = head $ I.objectInterfaces object
actualObjectPath = I.objectPath object
realParams =
if useObjectPath
then params {genObjectPath = Just actualObjectPath}
else params
(<++>) = liftA2 (++)
generateGetAllRecord recordGenerationParams params interface <++>
generateClient realParams interface <++>
generateSignalsFromInterface realParams interface
taffybar-4.0.1/src/System/Taffybar/DBus/ 0000755 0000000 0000000 00000000000 07346545000 016151 5 ustar 00 0000000 0000000 taffybar-4.0.1/src/System/Taffybar/DBus/Toggle.hs 0000644 0000000 0000000 00000014634 07346545000 017736 0 ustar 00 0000000 0000000 {-# LANGUAGE OverloadedStrings #-}
-----------------------------------------------------------------------------
-- |
-- Module : System.Taffybar.DBus.Toggle
-- Copyright : (c) Ivan A. Malison
-- License : BSD3-style (see LICENSE)
--
-- Maintainer : Ivan A. Malison
-- Stability : unstable
-- Portability : unportable
--
-- This module provides a dbus interface that allows users to toggle the display
-- of taffybar on each monitor while it is running.
-----------------------------------------------------------------------------
module System.Taffybar.DBus.Toggle ( handleDBusToggles ) where
import Control.Applicative
import qualified Control.Concurrent.MVar as MV
import Control.Exception
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.Class
import Control.Monad.Trans.Maybe
import Control.Monad.Trans.Reader
import DBus
import DBus.Client
import Data.Int
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
import System.Taffybar.Context
import System.Taffybar.Util
import Text.Printf
import Text.Read ( readMaybe )
-- $usage
--
-- To use this module, import it in your taffybar.hs and wrap your config with
-- the 'handleDBusToggles' function:
--
-- > main = dyreTaffybar $ handleDBusToggles myConfig
--
-- To toggle taffybar on the monitor that is currently active, issue the
-- following command:
--
-- > dbus-send --print-reply=literal --dest=taffybar.toggle /taffybar/toggle taffybar.toggle.toggleCurrent
logIO :: System.Log.Logger.Priority -> String -> IO ()
logIO = logM "System.Taffybar.DBus.Toggle"
logT :: MonadIO m => System.Log.Logger.Priority -> String -> m ()
logT p = liftIO . logIO p
getActiveMonitorNumber :: MaybeT IO Int
getActiveMonitorNumber = do
display <- MaybeT Gdk.displayGetDefault
seat <- lift $ Gdk.displayGetDefaultSeat display
device <- MaybeT $ Gdk.seatGetPointer seat
lift $ do
(_, x, y) <- Gdk.deviceGetPosition device
Gdk.displayGetMonitorAtPoint display x y >>= getMonitorNumber
getMonitorNumber :: Gdk.Monitor -> IO Int
getMonitorNumber monitor = do
display <- Gdk.monitorGetDisplay monitor
monitorCount <- Gdk.displayGetNMonitors display
monitors <- mapM (Gdk.displayGetMonitor display) [0..(monitorCount-1)]
monitorGeometry <- Gdk.getMonitorGeometry monitor
let equalsMonitor (Just other, _) =
do
otherGeometry <- Gdk.getMonitorGeometry other
case (otherGeometry, monitorGeometry) of
(Nothing, Nothing) -> return True
(Just g1, Just g2) -> Gdk.rectangleEqual g1 g2
_ -> return False
equalsMonitor _ = return False
snd . fromMaybe (Nothing, 0) . listToMaybe <$>
filterM equalsMonitor (zip monitors [0..])
taffybarTogglePath :: ObjectPath
taffybarTogglePath = "/taffybar/toggle"
taffybarToggleInterface :: InterfaceName
taffybarToggleInterface = "taffybar.toggle"
toggleStateFile :: IO FilePath
toggleStateFile = ( "toggle_state.dat") <$> taffyStateDir
newtype TogglesMVar = TogglesMVar (MV.MVar (M.Map Int Bool))
getTogglesVar :: TaffyIO TogglesMVar
getTogglesVar = getStateDefault $ lift (TogglesMVar <$> MV.newMVar M.empty)
toggleBarConfigGetter :: BarConfigGetter -> BarConfigGetter
toggleBarConfigGetter getConfigs = do
barConfigs <- getConfigs
TogglesMVar enabledVar <- getTogglesVar
numToEnabled <- lift $ MV.readMVar enabledVar
let isEnabled monNumber = fromMaybe True $ M.lookup monNumber numToEnabled
isConfigEnabled =
isEnabled . fromIntegral . fromMaybe 0 . strutMonitor . strutConfig
return $ filter isConfigEnabled barConfigs
exportTogglesInterface :: TaffyIO ()
exportTogglesInterface = do
TogglesMVar enabledVar <- getTogglesVar
ctx <- ask
lift $ taffyStateDir >>= createDirectoryIfMissing True
stateFile <- lift toggleStateFile
let toggleTaffyOnMon fn mon = flip runReaderT ctx $ do
lift $ MV.modifyMVar_ enabledVar $ \numToEnabled -> do
let current = fromMaybe True $ M.lookup mon numToEnabled
result = M.insert mon (fn current) numToEnabled
logIO DEBUG $ printf "Toggle state before: %s, after %s"
(show numToEnabled) (show result)
catch (writeFile stateFile (show result)) $ \e ->
logIO WARNING $ printf "Unable to write to toggle state file %s, error: %s"
(show stateFile) (show (e :: SomeException))
return result
refreshTaffyWindows
toggleTaffy = do
num <- runMaybeT getActiveMonitorNumber
toggleTaffyOnMon not $ fromMaybe 0 num
takeInt :: (Int -> a) -> (Int32 -> a)
takeInt = (. fromIntegral)
client <- asks sessionDBusClient
let interface =
defaultInterface
{ interfaceName = taffybarToggleInterface
, interfaceMethods =
[ autoMethod "toggleCurrent" toggleTaffy
, autoMethod "toggleOnMonitor" $ takeInt $ toggleTaffyOnMon not
, autoMethod "hideOnMonitor" $
takeInt $ toggleTaffyOnMon (const False)
, autoMethod "showOnMonitor" $
takeInt $ toggleTaffyOnMon (const True)
, autoMethod "refresh" $ runReaderT refreshTaffyWindows ctx
, autoMethod "exit" (Gtk.mainQuit :: IO ())
]
}
lift $ do
_ <- requestName client "taffybar.toggle"
[nameAllowReplacement, nameReplaceExisting]
export client taffybarTogglePath interface
dbusTogglesStartupHook :: TaffyIO ()
dbusTogglesStartupHook = do
TogglesMVar enabledVar <- getTogglesVar
logT DEBUG "Loading toggle state"
lift $ do
stateFilepath <- toggleStateFile
filepathExists <- doesFileExist stateFilepath
mStartingMap <-
if filepathExists
then
readMaybe <$> readFile stateFilepath
else
return Nothing
MV.modifyMVar_ enabledVar $ const $ return $ fromMaybe M.empty mStartingMap
logT DEBUG "Exporting toggles interface"
exportTogglesInterface
handleDBusToggles :: TaffybarConfig -> TaffybarConfig
handleDBusToggles config =
config { getBarConfigsParam =
toggleBarConfigGetter $ getBarConfigsParam config
, startupHook = startupHook config >> dbusTogglesStartupHook
}
taffybar-4.0.1/src/System/Taffybar/Example.hs 0000644 0000000 0000000 00000006154 07346545000 017251 0 ustar 00 0000000 0000000 {-# LANGUAGE OverloadedStrings #-}
-----------------------------------------------------------------------------
-- |
-- Module : System.Taffybar.Example
-- Copyright : (c) Ivan A. Malison
-- License : BSD3-style (see LICENSE)
--
-- Maintainer : Ivan A. Malison
-- Stability : unstable
-- Portability : unportable
-----------------------------------------------------------------------------
module System.Taffybar.Example where
-- XXX: in an actual taffybar.hs configuration file, you will need the module
-- name to be Main, and you would need to have a main function defined at the
-- top level, e.g.
--
-- > main = dyreTaffybar exampleTaffybarConfig
import Data.Default (def)
import System.Taffybar.Context (TaffybarConfig(..))
import System.Taffybar.Hooks
import System.Taffybar.Information.CPU
import System.Taffybar.Information.Memory
import System.Taffybar.SimpleConfig
import System.Taffybar.Widget
import System.Taffybar.Widget.Generic.PollingGraph
transparent, yellow1, yellow2, green1, green2, taffyBlue
:: (Double, Double, Double, Double)
transparent = (0.0, 0.0, 0.0, 0.0)
yellow1 = (0.9453125, 0.63671875, 0.2109375, 1.0)
yellow2 = (0.9921875, 0.796875, 0.32421875, 1.0)
green1 = (0, 1, 0, 1)
green2 = (1, 0, 1, 0.5)
taffyBlue = (0.129, 0.588, 0.953, 1)
myGraphConfig, netCfg, memCfg, cpuCfg :: GraphConfig
myGraphConfig =
def
{ graphPadding = 0
, graphBorderWidth = 0
, graphWidth = 75
, graphBackgroundColor = transparent
}
netCfg = myGraphConfig
{ graphDataColors = [yellow1, yellow2]
, graphLabel = Just "net"
}
memCfg = myGraphConfig
{ graphDataColors = [taffyBlue]
, graphLabel = Just "mem"
}
cpuCfg = myGraphConfig
{ graphDataColors = [green1, green2]
, graphLabel = Just "cpu"
}
memCallback :: IO [Double]
memCallback = do
mi <- parseMeminfo
return [memoryUsedRatio mi]
cpuCallback :: IO [Double]
cpuCallback = do
(_, systemLoad, totalLoad) <- cpuLoad
return [totalLoad, systemLoad]
exampleTaffybarConfig :: TaffybarConfig
exampleTaffybarConfig =
let myWorkspacesConfig =
def
{ minIcons = 1
, widgetGap = 0
, showWorkspaceFn = hideEmpty
}
workspaces = workspacesNew myWorkspacesConfig
cpu = pollingGraphNew cpuCfg 0.5 cpuCallback
mem = pollingGraphNew memCfg 1 memCallback
net = networkGraphNew netCfg Nothing
clock = textClockNewWith def
layout = layoutNew def
windowsW = windowsNew def
-- See https://github.com/taffybar/gtk-sni-tray#statusnotifierwatcher
-- for a better way to set up the sni tray
tray = sniTrayThatStartsWatcherEvenThoughThisIsABadWayToDoIt
myConfig = def
{ startWidgets =
workspaces : map (>>= buildContentsBox) [ layout, windowsW ]
, endWidgets = map (>>= buildContentsBox)
[ batteryIconNew
, clock
, tray
, cpu
, mem
, net
, mpris2New
]
, barPosition = Top
, barPadding = 10
, barHeight = ExactSize 50
, widgetSpacing = 0
}
in withBatteryRefresh $ withLogServer $
withToggleServer $ toTaffyConfig myConfig
taffybar-4.0.1/src/System/Taffybar/Hooks.hs 0000644 0000000 0000000 00000006237 07346545000 016743 0 ustar 00 0000000 0000000 -----------------------------------------------------------------------------
-- |
-- Module : System.Taffybar.Hooks
-- Copyright : (c) Ivan A. Malison
-- License : BSD3-style (see LICENSE)
--
-- Maintainer : Ivan A. Malison
-- Stability : unstable
-- Portability : unportable
--
-- This module provides various startup hooks that can be added to 'TaffyConfig'.
-----------------------------------------------------------------------------
module System.Taffybar.Hooks
( module System.Taffybar.DBus
, module System.Taffybar.Hooks
, ChromeTabImageData(..)
, getChromeTabImageDataChannel
, getChromeTabImageDataTable
, getX11WindowToChromeTabId
, refreshBatteriesOnPropChange
) where
import BroadcastChan
import Control.Concurrent
import Control.Monad
import Control.Monad.Trans.Class
import Control.Monad.Trans.Reader
import qualified Data.MultiMap as MM
import System.Log.Logger
import System.Taffybar.Context
import System.Taffybar.DBus
import System.Taffybar.Information.Battery
import System.Taffybar.Information.Chrome
import System.Taffybar.Information.Network
import System.Environment.XDG.DesktopEntry
import System.Taffybar.LogFormatter
import System.Taffybar.Util
-- | The type of the channel that provides network information in taffybar.
newtype NetworkInfoChan =
NetworkInfoChan (BroadcastChan In [(String, (Rational, Rational))])
-- | Build a 'NetworkInfoChan' that refreshes at the provided interval.
buildNetworkInfoChan :: Double -> IO NetworkInfoChan
buildNetworkInfoChan interval = do
chan <- newBroadcastChan
_ <- forkIO $ monitorNetworkInterfaces interval (void . writeBChan chan)
return $ NetworkInfoChan chan
-- | Get the 'NetworkInfoChan' from 'Context', creating it if it does not exist.
getNetworkChan :: TaffyIO NetworkInfoChan
getNetworkChan = getStateDefault $ lift $ buildNetworkInfoChan 2.0
-- | Set the log formatter used in the taffybar process
setTaffyLogFormatter :: String -> IO ()
setTaffyLogFormatter loggerName = do
handler <- taffyLogHandler
updateGlobalLogger loggerName $ setHandlers [handler]
-- | Add 'refreshrefreshBatteriesOnPropChange' to the 'startupHook' of the
-- provided 'TaffybarConfig'.
withBatteryRefresh :: TaffybarConfig -> TaffybarConfig
withBatteryRefresh = appendHook refreshBatteriesOnPropChange
-- | Load the 'DesktopEntry' cache from 'Context' state.
getDirectoryEntriesByClassName :: TaffyIO (MM.MultiMap String DesktopEntry)
getDirectoryEntriesByClassName =
getStateDefault readDirectoryEntriesDefault
-- | Update the 'DesktopEntry' cache every 60 seconds.
updateDirectoryEntriesCache :: TaffyIO ()
updateDirectoryEntriesCache = ask >>= \ctx ->
void $ lift $ foreverWithDelay (60 :: Double) $ flip runReaderT ctx $
void $ putState readDirectoryEntriesDefault
-- | Read 'DesktopEntry' values into a 'MM.Multimap', where they are indexed by
-- the class name specified in the 'DesktopEntry'.
readDirectoryEntriesDefault :: TaffyIO (MM.MultiMap String DesktopEntry)
readDirectoryEntriesDefault = lift $
indexDesktopEntriesByClassName <$> getDirectoryEntriesDefault
taffybar-4.0.1/src/System/Taffybar/Information/ 0000755 0000000 0000000 00000000000 07346545000 017601 5 ustar 00 0000000 0000000 taffybar-4.0.1/src/System/Taffybar/Information/Battery.hs 0000644 0000000 0000000 00000025645 07346545000 021563 0 ustar 00 0000000 0000000 {-# LANGUAGE OverloadedStrings #-}
-----------------------------------------------------------------------------
-- |
-- Module : System.Taffybar.Information.Battery
-- Copyright : (c) Ivan A. Malison
-- License : BSD3-style (see LICENSE)
--
-- Maintainer : Ivan A. Malison
-- Stability : unstable
-- Portability : unportable
--
-- This module provides functions for querying battery information using the
-- UPower dbus, as well as a "BroadcastChan" system for allowing multiple
-- readers to receive 'BatteryState' updates without duplicating requests.
-----------------------------------------------------------------------------
module System.Taffybar.Information.Battery
( BatteryInfo(..)
, BatteryState(..)
, BatteryTechnology(..)
, BatteryType(..)
, module System.Taffybar.Information.Battery
) where
import BroadcastChan
import Control.Concurrent
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.Class
import Control.Monad.Trans.Except
import Control.Monad.Trans.Reader
import DBus
import DBus.Client
import DBus.Internal.Types (Serial(..))
import qualified DBus.TH as DBus
import Data.Int
import Data.List
import Data.Map ( Map )
import qualified Data.Map as M
import Data.Maybe
import Data.Text ( Text )
import Data.Word
import System.Log.Logger
import System.Taffybar.Context
import System.Taffybar.DBus.Client.Params
import System.Taffybar.DBus.Client.UPower
import System.Taffybar.DBus.Client.UPowerDevice
import System.Taffybar.Util
batteryLogPath :: String
batteryLogPath = "System.Taffybar.Information.Battery"
batteryLog
:: MonadIO m
=> Priority -> String -> m ()
batteryLog priority = liftIO . logM batteryLogPath priority
batteryLogF
:: (MonadIO m, Show t)
=> Priority -> String -> t -> m ()
batteryLogF = logPrintF batteryLogPath
-- | 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_"
-- | Determine if a power source is a battery.
isBattery :: ObjectPath -> Bool
isBattery = isPrefixOf batteryPrefix . formatObjectPath
-- | A helper to read the variant contents of a dict with a default
-- value.
readDict :: (IsVariant a) => Map Text Variant -> Text -> a -> a
readDict dict key dflt = fromMaybe dflt $ do
variant <- M.lookup key dict
fromVariant variant
-- | Read the variant contents of a dict which is of an unknown integral type.
readDictIntegral :: Map Text Variant -> Text -> Int32 -> Int
readDictIntegral dict key dflt = fromMaybe (fromIntegral dflt) $ do
v <- M.lookup key dict
case variantType v of
TypeWord8 -> return $ fromIntegral (f v :: Word8)
TypeWord16 -> return $ fromIntegral (f v :: Word16)
TypeWord32 -> return $ fromIntegral (f v :: Word32)
TypeWord64 -> return $ fromIntegral (f v :: Word64)
TypeInt16 -> return $ fromIntegral (f v :: Int16)
TypeInt32 -> return $ fromIntegral (f v :: Int32)
TypeInt64 -> return $ fromIntegral (f v :: Int64)
_ -> Nothing
where
f :: (Num a, IsVariant a) => Variant -> a
f = fromMaybe (fromIntegral dflt) . fromVariant
-- XXX: Remove this once it is exposed in haskell-dbus
dummyMethodError :: MethodError
dummyMethodError = methodError (Serial 1) $ errorName_ "org.ClientTypeMismatch"
-- | Query the UPower daemon about information on a specific battery.
-- If some fields are not actually present, they may have bogus values
-- here. Don't bet anything critical on it.
getBatteryInfo :: ObjectPath -> TaffyIO (Either MethodError BatteryInfo)
getBatteryInfo battPath = asks systemDBusClient >>= \client -> lift $ runExceptT $ do
reply <- ExceptT $ getAllProperties client $
(methodCall battPath uPowerDeviceInterfaceName "FakeMethod")
{ methodCallDestination = Just uPowerBusName }
dict <- ExceptT $ return $ maybeToEither dummyMethodError $
listToMaybe (methodReturnBody reply) >>= fromVariant
return $ infoMapToBatteryInfo dict
infoMapToBatteryInfo :: Map Text Variant -> BatteryInfo
infoMapToBatteryInfo dict =
BatteryInfo
{ batteryNativePath = readDict dict "NativePath" ""
, batteryVendor = readDict dict "Vendor" ""
, batteryModel = readDict dict "Model" ""
, batterySerial = readDict dict "Serial" ""
, batteryType = toEnum $ fromIntegral $ readDictIntegral dict "Type" 0
, batteryPowerSupply = readDict dict "PowerSupply" False
, batteryHasHistory = readDict dict "HasHistory" False
, batteryHasStatistics = readDict dict "HasStatistics" False
, batteryOnline = readDict dict "Online" False
, batteryEnergy = readDict dict "Energy" 0.0
, batteryEnergyEmpty = readDict dict "EnergyEmpty" 0.0
, batteryEnergyFull = readDict dict "EnergyFull" 0.0
, batteryEnergyFullDesign = readDict dict "EnergyFullDesign" 0.0
, batteryEnergyRate = readDict dict "EnergyRate" 0.0
, batteryVoltage = readDict dict "Voltage" 0.0
, batteryTimeToEmpty = readDict dict "TimeToEmpty" 0
, batteryTimeToFull = readDict dict "TimeToFull" 0
, batteryPercentage = readDict dict "Percentage" 0.0
, batteryIsPresent = readDict dict "IsPresent" False
, batteryState = toEnum $ readDictIntegral dict "State" 0
, batteryIsRechargeable = readDict dict "IsRechargable" True
, batteryCapacity = readDict dict "Capacity" 0.0
, batteryTechnology =
toEnum $ fromIntegral $ readDictIntegral dict "Technology" 0
, batteryUpdateTime = readDict dict "UpdateTime" 0
, batteryLuminosity = readDict dict "Luminosity" 0.0
, batteryTemperature = readDict dict "Temperature" 0.0
, batteryWarningLevel = readDict dict "WarningLevel" 0
, batteryBatteryLevel = readDict dict "BatteryLevel" 0
, batteryIconName = readDict dict "IconName" ""
}
getBatteryPaths :: TaffyIO (Either MethodError [ObjectPath])
getBatteryPaths = do
client <- asks systemDBusClient
liftIO $ runExceptT $ do
paths <- ExceptT $ enumerateDevices client
return $ filter isBattery paths
newtype DisplayBatteryChanVar =
DisplayBatteryChanVar (BroadcastChan In BatteryInfo, MVar BatteryInfo)
getDisplayBatteryInfo :: TaffyIO BatteryInfo
getDisplayBatteryInfo = do
DisplayBatteryChanVar (_, theVar) <- getDisplayBatteryChanVar
lift $ readMVar theVar
defaultMonitorDisplayBatteryProperties :: [String]
defaultMonitorDisplayBatteryProperties = [ "IconName", "State", "Percentage" ]
-- | Start the monitoring of the display battery, and setup the associated
-- channel and mvar for the current state.
setupDisplayBatteryChanVar :: [String] -> TaffyIO DisplayBatteryChanVar
setupDisplayBatteryChanVar properties = getStateDefault $
DisplayBatteryChanVar <$> monitorDisplayBattery properties
getDisplayBatteryChanVar :: TaffyIO DisplayBatteryChanVar
getDisplayBatteryChanVar =
setupDisplayBatteryChanVar defaultMonitorDisplayBatteryProperties
getDisplayBatteryChan :: TaffyIO (BroadcastChan In BatteryInfo)
getDisplayBatteryChan = do
DisplayBatteryChanVar (chan, _) <- getDisplayBatteryChanVar
return chan
updateBatteryInfo
:: BroadcastChan In BatteryInfo
-> MVar BatteryInfo
-> ObjectPath
-> TaffyIO ()
updateBatteryInfo chan var path =
getBatteryInfo path >>= lift . either warnOfFailure doWrites
where
doWrites info =
batteryLogF DEBUG "Writing info %s" info >>
swapMVar var info >> void (writeBChan chan info)
warnOfFailure = batteryLogF WARNING "Failed to update battery info %s"
registerForAnyUPowerPropertiesChanged
:: (Signal -> String -> Map String Variant -> [String] -> IO ())
-> ReaderT Context IO SignalHandler
registerForAnyUPowerPropertiesChanged = registerForUPowerPropertyChanges []
registerForUPowerPropertyChanges
:: [String]
-> (Signal -> String -> Map String Variant -> [String] -> IO ())
-> ReaderT Context IO SignalHandler
registerForUPowerPropertyChanges properties signalHandler = do
client <- asks systemDBusClient
lift $ DBus.registerForPropertiesChanged
client
matchAny { matchInterface = Just uPowerDeviceInterfaceName }
handleIfPropertyMatches
where handleIfPropertyMatches rawSignal n propertiesMap l =
let propertyPresent prop = isJust $ M.lookup prop propertiesMap
in when (any propertyPresent properties || null properties) $
signalHandler rawSignal n propertiesMap l
-- | Monitor the DisplayDevice for changes, writing a new "BatteryInfo" object
-- to returned "MVar" and "Chan" objects
monitorDisplayBattery ::
[String] -> TaffyIO (BroadcastChan In BatteryInfo, MVar BatteryInfo)
monitorDisplayBattery propertiesToMonitor = do
lift $ batteryLog DEBUG "Starting Battery Monitor"
client <- asks systemDBusClient
infoVar <- lift $ newMVar $ infoMapToBatteryInfo M.empty
chan <- newBroadcastChan
taffyFork $ do
ctx <- ask
let warnOfFailedGetDevice err =
batteryLogF WARNING "Failure getting DisplayBattery: %s" err >>
return "/org/freedesktop/UPower/devices/DisplayDevice"
displayPath <- lift $ getDisplayDevice client >>=
either warnOfFailedGetDevice return
let doUpdate = updateBatteryInfo chan infoVar displayPath
signalCallback _ _ changedProps _ =
do
batteryLogF DEBUG "Battery changed properties: %s" changedProps
runReaderT doUpdate ctx
_ <- registerForUPowerPropertyChanges propertiesToMonitor signalCallback
doUpdate
return ()
return (chan, infoVar)
-- | Call "refreshAllBatteries" whenever the BatteryInfo for the DisplayDevice
-- is updated. This handles cases where there is a race between the signal that
-- something is updated and the update actually being visible. See
-- https://github.com/taffybar/taffybar/issues/330 for more details.
refreshBatteriesOnPropChange :: TaffyIO ()
refreshBatteriesOnPropChange = ask >>= \ctx ->
let updateIfRealChange _ _ changedProps _ =
flip runReaderT ctx $
when (any ((`notElem` ["UpdateTime", "Voltage"]) . fst) $
M.toList changedProps) $
lift (threadDelay 1000000) >> refreshAllBatteries
in void $ registerForAnyUPowerPropertiesChanged updateIfRealChange
-- | Request a refresh of all UPower batteries. This is only needed if UPower's
-- refresh mechanism is not working properly.
refreshAllBatteries :: TaffyIO ()
refreshAllBatteries = do
client <- asks systemDBusClient
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"
logGetPathsError = batteryLogF ERROR "Failed to get battery paths %s"
void $ either logGetPathsError (mapM_ $ either logRefreshError return) eerror
taffybar-4.0.1/src/System/Taffybar/Information/CPU.hs 0000644 0000000 0000000 00000001672 07346545000 020572 0 ustar 00 0000000 0000000 module System.Taffybar.Information.CPU ( cpuLoad ) where
import Control.Concurrent ( threadDelay )
import System.IO ( IOMode(ReadMode), openFile, hGetLine, hClose )
procData :: IO [Double]
procData = do
h <- openFile "/proc/stat" ReadMode
firstLine <- hGetLine h
length firstLine `seq` return ()
hClose h
return (procParser firstLine)
procParser :: String -> [Double]
procParser = map read . tail . words
truncVal :: Double -> Double
truncVal v
| isNaN v || v < 0.0 = 0.0
| otherwise = v
-- | Return a pair with (user time, system time, total time) (read
-- from /proc/stat). The function waits for 50 ms between samples.
cpuLoad :: IO (Double, Double, Double)
cpuLoad = do
a <- procData
threadDelay 50000
b <- procData
let dif = zipWith (-) b a
tot = sum dif
pct = map (/ tot) dif
user = sum $ take 2 pct
system = pct !! 2
t = user + system
return (truncVal user, truncVal system, truncVal t)
taffybar-4.0.1/src/System/Taffybar/Information/CPU2.hs 0000644 0000000 0000000 00000005255 07346545000 020655 0 ustar 00 0000000 0000000 {-# LANGUAGE TupleSections #-}
-----------------------------------------------------------------------------
-- |
-- Module : System.Taffybar.Information.CPU2
-- Copyright : (c) José A. Romero L.
-- License : BSD3-style (see LICENSE)
--
-- Maintainer : José A. Romero L.
-- Stability : unstable
-- Portability : unportable
--
-- Provides information about used CPU times, obtained from parsing the
-- @\/proc\/stat@ file using some of the facilities included in the
-- "System.Taffybar.Information.StreamInfo" module.
-- And also provides information about the temperature of cores.
-- (Now supports only physical cpu).
--
-----------------------------------------------------------------------------
module System.Taffybar.Information.CPU2 where
import Control.Monad
import Data.List
import Data.Maybe
import Safe
import System.Directory
import System.FilePath
import System.Taffybar.Information.StreamInfo
-- | Returns a list of 5 to 7 elements containing all the values available for
-- the given core (or all of them aggregated, if "cpu" is passed).
getCPUInfo :: String -> IO [Int]
getCPUInfo = getParsedInfo "/proc/stat" parse
parse :: String -> [(String, [Int])]
parse = mapMaybe (tuplize . words) . filter (\x -> take 3 x == "cpu") . lines
tuplize :: [String] -> Maybe (String, [Int])
tuplize s = do
cpu <- s `atMay` 0
return (cpu, map (readDef (-1)) (tailSafe s))
-- | Returns a two-element list containing relative system and user times
-- calculated using two almost simultaneous samples of the @\/proc\/stat@ file
-- for the given core (or all of them aggregated, if \"cpu\" is passed).
getCPULoad :: String -> IO [Double]
getCPULoad cpu = do
load <- getLoad 0.05 $ getCPUInfo cpu
case load of
l0:l1:l2:_ -> return [ l0 + l1, l2 ]
_ -> return []
-- | Get the directory in which core temperature files are kept.
getCPUTemperatureDirectory :: IO FilePath
getCPUTemperatureDirectory =
(baseDir ) . fromMaybe "hwmon0" .
find (isPrefixOf "hwmon")
<$> listDirectory baseDir
where baseDir =
"/" "sys" "bus" "platform"
"devices" "coretemp.0" "hwmon"
readCPUTempFile :: FilePath -> IO Double
readCPUTempFile cpuTempFilePath = (/ 1000) . read <$> readFile cpuTempFilePath
getAllTemperatureFiles :: FilePath -> IO [FilePath]
getAllTemperatureFiles temperaturesDirectory =
filter (liftM2 (&&) (isPrefixOf "temp") (isSuffixOf "input")) <$>
listDirectory temperaturesDirectory
getCPUTemperatures :: IO [(String, Double)]
getCPUTemperatures = do
dir <- getCPUTemperatureDirectory
let mkPair filename = (filename,) <$> readCPUTempFile (dir filename)
getAllTemperatureFiles dir >>= mapM mkPair
taffybar-4.0.1/src/System/Taffybar/Information/Chrome.hs 0000644 0000000 0000000 00000010611 07346545000 021351 0 ustar 00 0000000 0000000 {-# LANGUAGE OverloadedStrings #-}
module System.Taffybar.Information.Chrome where
import BroadcastChan
import Control.Concurrent
import Control.Monad
import Control.Monad.Trans.Class
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LBS
import qualified Data.Map as M
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
import System.Taffybar.Information.SafeX11
import Text.Read hiding (lift)
import Text.Regex
import Web.Scotty
logIO :: System.Log.Logger.Priority -> String -> IO ()
logIO = logM "System.Taffybar.Information.Chrome"
data ChromeTabImageData = ChromeTabImageData
{ tabImageData :: Gdk.Pixbuf
, tabImageDataId :: Int
}
newtype ChromeTabImageDataState =
ChromeTabImageDataState
(MVar (M.Map Int ChromeTabImageData), BroadcastChan Out ChromeTabImageData)
getChromeTabImageDataState :: TaffyIO ChromeTabImageDataState
getChromeTabImageDataState = do
ChromeFaviconServerPort port <- fromMaybe (ChromeFaviconServerPort 5000) <$> getState
getStateDefault (listenForChromeFaviconUpdates port)
getChromeTabImageDataChannel :: TaffyIO (BroadcastChan Out ChromeTabImageData)
getChromeTabImageDataChannel = do
ChromeTabImageDataState (_, chan) <- getChromeTabImageDataState
return chan
getChromeTabImageDataTable :: TaffyIO (MVar (M.Map Int ChromeTabImageData))
getChromeTabImageDataTable = do
ChromeTabImageDataState (table, _) <- getChromeTabImageDataState
return table
newtype ChromeFaviconServerPort = ChromeFaviconServerPort Int
listenForChromeFaviconUpdates :: Int -> TaffyIO ChromeTabImageDataState
listenForChromeFaviconUpdates port = do
infoVar <- lift $ newMVar M.empty
inChan <- newBroadcastChan
outChan <- newBChanListener inChan
_ <- lift $ forkIO $ scotty port $
post "/setTabImageData/:tabID" $ do
tabID <- param "tabID"
imageData <- LBS.toStrict <$> body
when (BS.length imageData > 0) $ lift $ do
loader <- Gdk.pixbufLoaderNew
Gdk.pixbufLoaderWriteBytes loader =<< Gdk.bytesNew (Just imageData)
Gdk.pixbufLoaderClose loader
let updateChannelAndMVar pixbuf =
let chromeTabImageData =
ChromeTabImageData
{ tabImageData = pixbuf
, tabImageDataId = tabID
}
in
modifyMVar_ infoVar $ \currentMap ->
do
_ <- writeBChan inChan chromeTabImageData
return $ M.insert tabID chromeTabImageData currentMap
Gdk.pixbufLoaderGetPixbuf loader >>= maybe (return ()) updateChannelAndMVar
return $ ChromeTabImageDataState (infoVar, outChan)
newtype X11WindowToChromeTabId = X11WindowToChromeTabId (MVar (M.Map X11Window Int))
getX11WindowToChromeTabId :: TaffyIO X11WindowToChromeTabId
getX11WindowToChromeTabId =
getStateDefault $ X11WindowToChromeTabId <$> maintainX11WindowToChromeTabId
maintainX11WindowToChromeTabId :: TaffyIO (MVar (M.Map X11Window Int))
maintainX11WindowToChromeTabId = do
startTabMap <- updateTabMap M.empty
tabMapVar <- lift $ newMVar startTabMap
let handleEvent PropertyEvent { ev_window = window } =
do
title <- runX11Def "" $ getWindowTitle window
lift $ modifyMVar_ tabMapVar $ \currentMap -> do
let newMap = addTabIdEntry currentMap (window, title)
logIO DEBUG (show newMap)
return newMap
handleEvent _ = return ()
_ <- subscribeToPropertyEvents [ewmhWMName] handleEvent
return tabMapVar
tabIDRegex :: Regex
tabIDRegex = mkRegexWithOpts "[|]%([0-9]*)%[|]" True True
getTabIdFromTitle :: String -> Maybe Int
getTabIdFromTitle title =
matchRegex tabIDRegex title >>= listToMaybe >>= readMaybe
addTabIdEntry :: M.Map X11Window Int -> (X11Window, String) -> M.Map X11Window Int
addTabIdEntry theMap (win, title) =
maybe theMap ((flip $ M.insert win) theMap) $ getTabIdFromTitle title
updateTabMap :: M.Map X11Window Int -> TaffyIO (M.Map X11Window Int)
updateTabMap tabMap =
runX11Def tabMap $ do
wins <- getWindows
titles <- mapM getWindowTitle wins
let winsWithTitles = zip wins titles
return $ foldl addTabIdEntry tabMap winsWithTitles
taffybar-4.0.1/src/System/Taffybar/Information/Crypto.hs 0000644 0000000 0000000 00000012150 07346545000 021414 0 ustar 00 0000000 0000000 {-# LANGUAGE KindSignatures #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE OverloadedStrings #-}
-----------------------------------------------------------------------------
-- |
-- Module : System.Taffybar.Information.Crypto
-- Copyright : (c) Ivan A. Malison
-- License : BSD3-style (see LICENSE)
--
-- Maintainer : Ivan A. Malison
-- Stability : unstable
-- Portability : unportable
--
-- This module provides utility functions for retrieving data about crypto
-- assets.
-----------------------------------------------------------------------------
module System.Taffybar.Information.Crypto where
import BroadcastChan
import Control.Concurrent
import Control.Exception.Enclosed (catchAny)
import Control.Monad
import Control.Monad.IO.Class
import Data.Aeson
import Data.Aeson.Types (parseMaybe)
import qualified Data.Aeson.Key as Key
import qualified Data.ByteString.Lazy as LBS
import qualified Data.ByteString.UTF8 as BS
import qualified Data.Map as M
import Data.Maybe
import Data.Proxy
import qualified Data.Text as T
import GHC.TypeLits
import Network.HTTP.Simple hiding (Proxy)
import System.Log.Logger
import System.Taffybar.Context
import System.Taffybar.Util
import Text.Printf
getSymbolToCoinGeckoId :: MonadIO m => m (M.Map T.Text T.Text)
getSymbolToCoinGeckoId = do
let uri = "https://api.coingecko.com/api/v3/coins/list?include_platform=false"
request = parseRequest_ uri
bodyText <- liftIO $ catchAny (getResponseBody <$> httpLBS request) $ \e -> do
liftIO $ logM "System.Taffybar.Information.Crypto" WARNING $
printf "Error fetching coins list from coin gecko %s" $ show e
return ""
let coinInfos :: [CoinGeckoInfo]
coinInfos = fromMaybe [] $ decode bodyText
return $ M.fromList $ map (\CoinGeckoInfo { identifier = theId, symbol = theSymbol } ->
(theSymbol, theId)) coinInfos
newtype SymbolToCoinGeckoId = SymbolToCoinGeckoId (M.Map T.Text T.Text)
newtype CryptoPriceInfo = CryptoPriceInfo { lastPrice :: Double }
newtype CryptoPriceChannel (a :: Symbol) =
CryptoPriceChannel (BroadcastChan In CryptoPriceInfo, MVar CryptoPriceInfo)
getCryptoPriceChannel :: KnownSymbol a => TaffyIO (CryptoPriceChannel a)
getCryptoPriceChannel = do
-- XXX: This is a gross hack that is needed to avoid deadlock
symbolToId <- getStateDefault $ SymbolToCoinGeckoId <$> getSymbolToCoinGeckoId
getStateDefault $ buildCryptoPriceChannel (60.0 :: Double) symbolToId
data CoinGeckoInfo =
CoinGeckoInfo { identifier :: T.Text, symbol :: T.Text }
deriving (Show)
instance FromJSON CoinGeckoInfo where
parseJSON = withObject "CoinGeckoInfo" (\v -> CoinGeckoInfo <$> v .: "id" <*> v .: "symbol")
buildCryptoPriceChannel ::
forall a. KnownSymbol a => Double -> SymbolToCoinGeckoId -> TaffyIO (CryptoPriceChannel a)
buildCryptoPriceChannel delay (SymbolToCoinGeckoId symbolToId) = do
let initialBackoff = delay
chan <- newBroadcastChan
var <- liftIO $ newMVar $ CryptoPriceInfo 0.0
backoffVar <- liftIO $ newMVar initialBackoff
let doWrites info = do
_ <- swapMVar var info
_ <- writeBChan chan info
_ <- 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 ->
void $ foreverWithVariableDelay $
catchAny (liftIO $ getLatestPrice cgIdentifier (T.toLower inCurrency) >>=
maybe (return ()) (doWrites . CryptoPriceInfo) >> return delay) $ \e -> do
logPrintF "System.Taffybar.Information.Crypto"
WARNING "Error when fetching crypto price: %s" 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 tokenId inCurrency = do
let uri = printf "https://api.coingecko.com/api/v3/simple/price?ids=%s&vs_currencies=%s"
tokenId inCurrency
request = parseRequest_ uri
bodyText <- getResponseBody <$> httpLBS request
return $ decode bodyText >>= parseMaybe ((.: Key.fromText tokenId) >=> (.: Key.fromText inCurrency))
getCryptoMeta :: MonadIO m => String -> String -> m LBS.ByteString
getCryptoMeta cmcAPIKey symbolName = do
let headers = [("X-CMC_PRO_API_KEY", BS.fromString cmcAPIKey)] :: RequestHeaders
uri = printf "https://pro-api.coinmarketcap.com/v1/cryptocurrency/info?symbol=%s"
symbolName
request = setRequestHeaders headers $ parseRequest_ uri
getResponseBody <$> httpLBS request
taffybar-4.0.1/src/System/Taffybar/Information/DiskIO.hs 0000644 0000000 0000000 00000003115 07346545000 021257 0 ustar 00 0000000 0000000 -----------------------------------------------------------------------------
-- |
-- Module : System.Taffybar.Information.DiskIO
-- Copyright : (c) José A. Romero L.
-- License : BSD3-style (see LICENSE)
--
-- Maintainer : José A. Romero L.
-- Stability : unstable
-- Portability : unportable
--
-- Provides information about read/write operations in a given disk or
-- partition, obtained from parsing the @\/proc\/diskstats@ file with some
-- of the facilities included in the "System.Taffybar.Information.StreamInfo" module.
-----------------------------------------------------------------------------
module System.Taffybar.Information.DiskIO ( getDiskTransfer ) where
import Data.Maybe ( mapMaybe )
import Safe ( atMay, headMay, readDef )
import System.Taffybar.Information.StreamInfo ( getParsedInfo, getTransfer )
-- | Returns a two-element list containing the speed of transfer for read and
-- write operations performed in the given disk\/partition (e.g. \"sda\",
-- \"sda1\").
getDiskTransfer :: String -> IO [Double]
getDiskTransfer disk = getTransfer 0.05 $ getDiskInfo disk
-- | Returns the list of all the values available in @\/proc\/diskstats@
-- for the given disk or partition.
getDiskInfo :: String -> IO [Int]
getDiskInfo = getParsedInfo "/proc/diskstats" parse
parse :: String -> [(String, [Int])]
parse = mapMaybe (tuplize . drop 2 . words) . lines
tuplize :: [String] -> Maybe (String, [Int])
tuplize s = do
device <- headMay s
used <- s `atMay` 3
capacity <- s `atMay` 7
return (device, [readDef (-1) used, readDef (-1) capacity])
taffybar-4.0.1/src/System/Taffybar/Information/EWMHDesktopInfo.hs 0000644 0000000 0000000 00000023512 07346545000 023046 0 ustar 00 0000000 0000000 -----------------------------------------------------------------------------
-- |
-- Module : System.Taffybar.Information.EWMHDesktopInfo
-- Copyright : (c) José A. Romero L.
-- License : BSD3-style (see LICENSE)
--
-- Maintainer : José A. Romero L.
-- Stability : unstable
-- Portability : unportable
--
-- Functions to access data provided by the X11 desktop via EWHM hints. This
-- module requires that the EwmhDesktops hook from the XMonadContrib project
-- be installed in your @~\/.xmonad\/xmonad.hs@ configuration:
--
-- > import XMonad
-- > import XMonad.Hooks.EwmhDesktops (ewmh)
-- >
-- > main = xmonad $ ewmh $ ...
--
-----------------------------------------------------------------------------
module System.Taffybar.Information.EWMHDesktopInfo
( EWMHIcon(..)
, EWMHIconData
, WorkspaceId(..)
, X11Window
, allEWMHProperties
, ewmhActiveWindow
, ewmhClientList
, ewmhClientListStacking
, ewmhCurrentDesktop
, ewmhDesktopNames
, ewmhNumberOfDesktops
, ewmhStateHidden
, ewmhWMClass
, ewmhWMDesktop
, ewmhWMIcon
, ewmhWMName
, ewmhWMName2
, ewmhWMState
, ewmhWMStateHidden
, focusWindow
, getActiveWindow
, getCurrentWorkspace
, getVisibleWorkspaces
, getWindowClass
, getWindowIconsData
, getWindowMinimized
, getWindowState
, getWindowStateProperty
, getWindowTitle
, getWindows
, getWindowsStacking
, getWorkspace
, getWorkspaceNames
, isWindowUrgent
, parseWindowClasses
, switchOneWorkspace
, switchToWorkspace
, withDefaultCtx
, withEWMHIcons
) where
import Control.Applicative
import Control.Monad.IO.Class
import Control.Monad.Trans.Class
import Data.List
import Data.List.Split
import Data.Maybe
import Data.Tuple
import Data.Word
import Foreign.ForeignPtr
import Foreign.Marshal.Array
import Foreign.Ptr
import Foreign.Storable
import System.Log.Logger
import System.Taffybar.Information.SafeX11 hiding (logHere)
import System.Taffybar.Information.X11DesktopInfo
import Prelude
logHere :: MonadIO m => Priority -> String -> m ()
logHere p = liftIO . logM "System.Taffybar.Information.EWMHDesktopInfo" p
newtype WorkspaceId = WorkspaceId Int deriving (Show, Read, Ord, Eq)
-- A super annoying detail of the XGetWindowProperty interface is that: "If the
-- returned format is 32, the returned data is represented as a long array and
-- should be cast to that type to obtain the elements." This means that even
-- though only the 4 least significant bits will ever contain any data, the
-- array that is returned from X11 can have a larger word size. This means that
-- we need to manipulate the underlying data in annoying ways to pass it to gtk
-- appropriately.
type PixelsWordType = Word64
type EWMHProperty = String
ewmhActiveWindow, ewmhClientList, ewmhClientListStacking, ewmhCurrentDesktop, ewmhDesktopNames, ewmhNumberOfDesktops, ewmhStateHidden, ewmhWMDesktop, ewmhWMStateHidden, ewmhWMClass, ewmhWMState, ewmhWMIcon, ewmhWMName, ewmhWMName2 :: EWMHProperty
ewmhActiveWindow = "_NET_ACTIVE_WINDOW"
ewmhClientList = "_NET_CLIENT_LIST"
ewmhClientListStacking = "_NET_CLIENT_LIST_STACKING"
ewmhCurrentDesktop = "_NET_CURRENT_DESKTOP"
ewmhDesktopNames = "_NET_DESKTOP_NAMES"
ewmhNumberOfDesktops = "_NET_NUMBER_OF_DESKTOPS"
ewmhStateHidden = "_NET_WM_STATE_HIDDEN"
ewmhWMClass = "WM_CLASS"
ewmhWMDesktop = "_NET_WM_DESKTOP"
ewmhWMIcon = "_NET_WM_ICON"
ewmhWMName = "_NET_WM_NAME"
ewmhWMName2 = "WM_NAME"
ewmhWMState = "_NET_WM_STATE"
ewmhWMStateHidden = "_NET_WM_STATE_HIDDEN"
allEWMHProperties :: [EWMHProperty]
allEWMHProperties =
[ ewmhActiveWindow
, ewmhClientList
, ewmhClientListStacking
, ewmhCurrentDesktop
, ewmhDesktopNames
, ewmhNumberOfDesktops
, ewmhStateHidden
, ewmhWMClass
, ewmhWMDesktop
, ewmhWMIcon
, ewmhWMName
, ewmhWMName2
, ewmhWMState
, ewmhWMStateHidden
]
type EWMHIconData = (ForeignPtr PixelsWordType, Int)
data EWMHIcon = EWMHIcon
{ ewmhWidth :: Int
, ewmhHeight :: Int
, ewmhPixelsARGB :: Ptr PixelsWordType
} deriving (Show, Eq)
getWindowStateProperty :: String -> X11Window -> X11Property Bool
getWindowStateProperty property window =
not . null <$> getWindowState window [property]
getWindowState :: X11Window -> [String] -> X11Property [String]
getWindowState window request = do
let getAsLong s = fromIntegral <$> getAtom s
integers <- mapM getAsLong request
properties <- fetch getWindowProperty32 (Just window) ewmhWMState
let integerToString = zip integers request
present = intersect integers $ fromMaybe [] properties
presentStrings = map (`lookup` integerToString) present
return $ catMaybes presentStrings
-- | Get a bool reflecting whether window with provided X11Window is minimized
-- or not.
getWindowMinimized :: X11Window -> X11Property Bool
getWindowMinimized = getWindowStateProperty ewmhStateHidden
-- | Retrieve the index of the current workspace in the desktop, starting from
-- 0.
getCurrentWorkspace :: X11Property WorkspaceId
getCurrentWorkspace = WorkspaceId <$> readAsInt Nothing ewmhCurrentDesktop
-- | Retrieve the indexes of all currently visible workspaces
-- with the active workspace at the head of the list.
getVisibleWorkspaces :: X11Property [WorkspaceId]
getVisibleWorkspaces = do
vis <- getVisibleTags
allNames <- map swap <$> getWorkspaceNames
cur <- getCurrentWorkspace
return $ cur : mapMaybe (`lookup` allNames) vis
-- | Return a list with the names of all the workspaces currently
-- available.
getWorkspaceNames :: X11Property [(WorkspaceId, String)]
getWorkspaceNames = go <$> readAsListOfString Nothing ewmhDesktopNames
where go = zip [WorkspaceId i | i <- [0..]]
-- | Ask the window manager to switch to the workspace with the given
-- index, starting from 0.
switchToWorkspace :: WorkspaceId -> X11Property ()
switchToWorkspace (WorkspaceId idx) = do
cmd <- getAtom ewmhCurrentDesktop
sendCommandEvent cmd (fromIntegral idx)
-- | Move one workspace up or down from the current workspace
switchOneWorkspace :: Bool -> Int -> X11Property ()
switchOneWorkspace dir end = do
cur <- getCurrentWorkspace
switchToWorkspace $ if dir then getPrev cur end else getNext cur end
-- | Check for corner case and switch one workspace up
getPrev :: WorkspaceId -> Int -> WorkspaceId
getPrev (WorkspaceId idx) end
| idx > 0 = WorkspaceId $ idx-1
| otherwise = WorkspaceId end
-- | Check for corner case and switch one workspace down
getNext :: WorkspaceId -> Int -> WorkspaceId
getNext (WorkspaceId idx) end
| idx < end = WorkspaceId $ idx+1
| otherwise = WorkspaceId 0
-- | Get the title of the given X11 window.
getWindowTitle :: X11Window -> X11Property String
getWindowTitle window = do
let w = Just window
prop <- readAsString w ewmhWMName
case prop of
"" -> readAsString w ewmhWMName2
_ -> return prop
-- | Get the class of the given X11 window.
getWindowClass :: X11Window -> X11Property String
getWindowClass window = readAsString (Just window) ewmhWMClass
parseWindowClasses :: String -> [String]
parseWindowClasses = filter (not . null) . splitOn "\NUL"
-- | Get EWMHIconData for the given X11Window
getWindowIconsData :: X11Window -> X11Property (Maybe EWMHIconData)
getWindowIconsData window = do
dpy <- getDisplay
atom <- getAtom ewmhWMIcon
lift $ rawGetWindowPropertyBytes 32 dpy atom window
-- | Operate on the data contained in 'EWMHIconData' in the easier to interact
-- with format offered by 'EWMHIcon'. This function is much like
-- 'withForeignPtr' in that the 'EWMHIcon' values that are provided to the
-- callable argument should not be kept around in any way, because it can not be
-- guaranteed that the finalizer for the memory to which those icon objects
-- 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)
-- | Split icon raw integer data into EWMHIcons. Each icon raw data is an
-- integer for width, followed by height, followed by exactly (width*height)
-- ARGB pixels, optionally followed by the next icon.
--
-- XXX: This function should not be made public, because its return value contains
-- (sub)pointers whose allocation we do not control.
parseIcons :: Int -> Ptr PixelsWordType -> IO [EWMHIcon]
parseIcons 0 _ = return []
parseIcons totalSize arr = do
iwidth <- fromIntegral <$> peek arr
iheight <- fromIntegral <$> peekElemOff arr 1
let pixelsPtr = advancePtr arr 2
thisSize = iwidth * iheight
newArr = advancePtr pixelsPtr thisSize
thisIcon =
EWMHIcon
{ ewmhWidth = iwidth
, ewmhHeight = iheight
, ewmhPixelsARGB = pixelsPtr
}
getRes newSize
| newSize < 0 =
logHere ERROR "Attempt to recurse on negative value in parseIcons"
>> return []
| otherwise = (thisIcon :) <$> parseIcons newSize newArr
getRes $ totalSize - fromIntegral (thisSize + 2)
-- | Get the window that currently has focus if such a window exists.
getActiveWindow :: X11Property (Maybe X11Window)
getActiveWindow = listToMaybe . filter (> 0) <$> readAsListOfWindow Nothing ewmhActiveWindow
-- | Return a list of all @X11Window@s, sorted by initial mapping order, oldest to newest.
getWindows :: X11Property [X11Window]
getWindows = readAsListOfWindow Nothing ewmhClientList
-- | Return a list of all @X11Window@s, sorted in stacking order, bottom-to-top.
getWindowsStacking :: X11Property [X11Window]
getWindowsStacking = readAsListOfWindow Nothing ewmhClientListStacking
-- | Return the index (starting from 0) of the workspace on which the given
-- window is being displayed.
getWorkspace :: X11Window -> X11Property WorkspaceId
getWorkspace window = WorkspaceId <$> readAsInt (Just window) ewmhWMDesktop
-- | Ask the window manager to give focus to the given window.
focusWindow :: X11Window -> X11Property ()
focusWindow wh = do
cmd <- getAtom ewmhActiveWindow
sendWindowEvent cmd (fromIntegral wh)
taffybar-4.0.1/src/System/Taffybar/Information/MPRIS2.hs 0000644 0000000 0000000 00000005357 07346545000 021123 0 ustar 00 0000000 0000000 {-# LANGUAGE NoMonoLocalBinds #-}
{-# LANGUAGE FlexibleContexts #-}
-----------------------------------------------------------------------------
-- |
-- Module : System.Taffybar.Information.MPRIS2
-- Copyright : (c) Ivan A. Malison
-- License : BSD3-style (see LICENSE)
--
-- Maintainer : Ivan A. Malison
-- Stability : unstable
-- Portability : unportable
--
-----------------------------------------------------------------------------
module System.Taffybar.Information.MPRIS2 where
import Control.Applicative
import Control.Monad.IO.Class
import Control.Monad.Trans.Class
import Control.Monad.Trans.Except
import Control.Monad.Trans.Maybe
import qualified DBus
import qualified DBus.Client as DBus
import qualified DBus.Internal.Types as DBus
import qualified DBus.TH as DBus
import Data.Coerce
import Data.List
import qualified Data.Map as M
import Data.Maybe
import System.Log.Logger
import System.Taffybar.DBus.Client.MPRIS2
import Text.Printf
data NowPlaying = NowPlaying
{ npTitle :: String
, npArtists :: [String]
, npStatus :: String
, npBusName :: DBus.BusName
} deriving (Show, Eq)
eitherToMaybeWithLog :: (MonadIO m, Show a1) => Either a1 a2 -> m (Maybe a2)
eitherToMaybeWithLog (Right v) = return $ Just v
eitherToMaybeWithLog (Left e) = liftIO $ do
logM "System.Taffybar.Information.MPRIS2" WARNING $
printf "Got error: %s" $ show e
return Nothing
getNowPlayingInfo :: MonadIO m => DBus.Client -> m [NowPlaying]
getNowPlayingInfo client =
fmap (fromMaybe []) $ eitherToMaybeWithLog =<< liftIO (runExceptT $ do
allBusNames <- ExceptT $ DBus.listNames client
let mediaPlayerBusNames =
filter (isPrefixOf "org.mpris.MediaPlayer2.") allBusNames
getSongData _busName = runMaybeT $
do
let busName = coerce _busName
metadataMap <-
MaybeT $ getMetadata client busName >>= eitherToMaybeWithLog
(title, artists) <- MaybeT $ return $ getSongInfo metadataMap
status <- MaybeT $ getPlaybackStatus client busName >>=
eitherToMaybeWithLog
return NowPlaying { npTitle = title
, npArtists = artists
, npStatus = status
, npBusName = busName
}
lift $ catMaybes <$> mapM getSongData mediaPlayerBusNames)
getSongInfo :: M.Map String DBus.Variant -> Maybe (String, [String])
getSongInfo songData = do
let lookupVariant k = M.lookup k songData >>= DBus.fromVariant
artists <- lookupVariant "xesam:artist" <|> pure []
title <- lookupVariant "xesam:title"
return (title, artists)
taffybar-4.0.1/src/System/Taffybar/Information/Memory.hs 0000644 0000000 0000000 00000004333 07346545000 021410 0 ustar 00 0000000 0000000 module System.Taffybar.Information.Memory (
MemoryInfo(..),
parseMeminfo
) where
toMB :: String -> Double
toMB size = (read size :: Double) / 1024
data MemoryInfo = MemoryInfo
{ memoryTotal :: Double
, memoryFree :: Double
, memoryBuffer :: Double
, memoryCache :: Double
, memorySwapTotal :: Double
, memorySwapFree :: Double
, memorySwapUsed :: Double -- swapTotal - swapFree
, memorySwapUsedRatio :: Double -- swapUsed / swapTotal
, memoryAvailable :: Double -- An estimate of how much memory is available
, memoryRest :: Double -- free + buffer + cache
, memoryUsed :: Double -- total - rest
, memoryUsedRatio :: Double -- used / total
}
emptyMemoryInfo :: MemoryInfo
emptyMemoryInfo = MemoryInfo 0 0 0 0 0 0 0 0 0 0 0 0
parseLines :: [String] -> MemoryInfo -> MemoryInfo
parseLines (line:rest) memInfo = parseLines rest newMemInfo
where newMemInfo = case words line of
(label:size:_) ->
case label of
"MemTotal:" -> memInfo { memoryTotal = toMB size }
"MemFree:" -> memInfo { memoryFree = toMB size }
"MemAvailable:" -> memInfo { memoryAvailable = toMB size }
"Buffers:" -> memInfo { memoryBuffer = toMB size }
"Cached:" -> memInfo { memoryCache = toMB size }
"SwapTotal:" -> memInfo { memorySwapTotal = toMB size }
"SwapFree:" -> memInfo { memorySwapFree = toMB size }
_ -> memInfo
_ -> memInfo
parseLines _ memInfo = memInfo
parseMeminfo :: IO MemoryInfo
parseMeminfo = do
s <- readFile "/proc/meminfo"
let m = parseLines (lines s) emptyMemoryInfo
rest = memoryFree m + memoryBuffer m + memoryCache m
used = memoryTotal m - rest
usedRatio = used / memoryTotal m
swapUsed = memorySwapTotal m - memorySwapFree m
swapUsedRatio = swapUsed / memorySwapTotal m
return m { memoryRest = rest
, memoryUsed = used
, memoryUsedRatio = usedRatio
, memorySwapUsed = swapUsed
, memorySwapUsedRatio = swapUsedRatio
}
taffybar-4.0.1/src/System/Taffybar/Information/Network.hs 0000644 0000000 0000000 00000012071 07346545000 021567 0 ustar 00 0000000 0000000 -----------------------------------------------------------------------------
-- |
-- Module : System.Taffybar.Information.Network
-- Copyright : (c) José A. Romero L.
-- License : BSD3-style (see LICENSE)
--
-- Maintainer : José A. Romero L.
-- Stability : unstable
-- Portability : unportable
--
-- Provides information about network traffic over selected interfaces,
-- obtained from parsing the @\/proc\/net\/dev@ file using some of the
-- facilities provided by the "System.Taffybar.Information.StreamInfo" module.
--
-----------------------------------------------------------------------------
module System.Taffybar.Information.Network where
import Control.Applicative
import qualified Control.Concurrent.MVar as MV
import Control.Exception (catch, SomeException)
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.Maybe (MaybeT(..))
import Data.Maybe ( mapMaybe )
import Data.Time.Clock
import Data.Time.Clock.System
import Safe ( atMay, initSafe, readDef )
import System.Taffybar.Information.StreamInfo ( getParsedInfo )
import System.Taffybar.Util
import Prelude
networkInfoFile :: FilePath
networkInfoFile = "/proc/net/dev"
-- | Returns a two-element list containing the current number of bytes received
-- and transmitted via the given network interface (e.g. \"wlan0\"), according
-- to the contents of the @\/proc\/dev\/net@ file.
getNetInfo :: String -> IO (Maybe [Int])
getNetInfo iface = runMaybeT $ do
isInterfaceUp iface
handleFailure $ getParsedInfo networkInfoFile parseDevNet' iface
parseDevNet' :: String -> [(String, [Int])]
parseDevNet' input =
map makeList $ parseDevNet input
where makeList (a, (u, d)) = (a, [u, d])
parseDevNet :: String -> [(String, (Int, Int))]
parseDevNet = mapMaybe (getDeviceUpDown . words) . drop 2 . lines
getDeviceUpDown :: [String] -> Maybe (String, (Int, Int))
getDeviceUpDown s = do
dev <- initSafe <$> s `atMay` 0
down <- readDef (-1) <$> s `atMay` 1
up <- readDef (-1) <$> s `atMay` out
dev `seq` down `seq` up `seq` return (dev, (down, up))
where
out = length s - 8
-- Nothing if interface does not exist or is down
isInterfaceUp :: String -> MaybeT IO ()
isInterfaceUp iface = do
state <- handleFailure $ readFile $ "/sys/class/net/" ++ iface ++ "/operstate"
case state of
'u' : _ -> return ()
_ -> mzero
handleFailure :: IO a -> MaybeT IO a
handleFailure action = MaybeT $ catch (Just <$> action) eToNothing
where
eToNothing :: SomeException -> IO (Maybe a)
eToNothing _ = pure Nothing
getDeviceSamples :: IO (Maybe [TxSample])
getDeviceSamples = runMaybeT $ handleFailure $ do
contents <- readFile networkInfoFile
length contents `seq` return ()
time <- liftIO getSystemTime
let mkSample (device, (up, down)) =
TxSample { sampleUp = up
, sampleDown = down
, sampleTime = time
, sampleDevice = device
}
return $ map mkSample $ parseDevNet contents
data TxSample = TxSample
{ sampleUp :: Int
, sampleDown :: Int
, sampleTime :: SystemTime
, sampleDevice :: String
} deriving (Show, Eq)
monitorNetworkInterfaces
:: RealFrac a1
=> a1 -> ([(String, (Rational, Rational))] -> IO ()) -> IO ()
monitorNetworkInterfaces interval onUpdate = void $ do
samplesVar <- MV.newMVar []
let sampleToSpeeds (device, (s1, s2)) = (device, getSpeed s1 s2)
doOnUpdate samples = do
let speedInfo = map sampleToSpeeds samples
onUpdate speedInfo
return samples
doUpdate = MV.modifyMVar_ samplesVar ((>>= doOnUpdate) . updateSamples)
foreverWithDelay interval doUpdate
updateSamples ::
[(String, (TxSample, TxSample))] ->
IO [(String, (TxSample, TxSample))]
updateSamples currentSamples = do
let getLast sample@TxSample { sampleDevice = device } =
maybe sample fst $ lookup device currentSamples
getSamplePair sample@TxSample { sampleDevice = device } =
let lastSample = getLast sample
in lastSample `seq` (device, (sample, lastSample))
maybe currentSamples (map getSamplePair) <$> getDeviceSamples
getSpeed :: TxSample -> TxSample -> (Rational, Rational)
getSpeed TxSample { sampleUp = thisUp
, sampleDown = thisDown
, sampleTime = thisTime
}
TxSample { sampleUp = lastUp
, sampleDown = lastDown
, sampleTime = lastTime
} =
let intervalDiffTime =
diffUTCTime
(systemToUTCTime thisTime)
(systemToUTCTime lastTime)
intervalRatio =
if intervalDiffTime == 0
then 0
else toRational $ 1 / intervalDiffTime
in ( fromIntegral (thisDown - lastDown) * intervalRatio
, fromIntegral (thisUp - lastUp) * intervalRatio
)
sumSpeeds :: [(Rational, Rational)] -> (Rational, Rational)
sumSpeeds = foldr1 sumOne
where
sumOne (d1, u1) (d2, u2) = (d1 + d2, u1 + u2)
taffybar-4.0.1/src/System/Taffybar/Information/SafeX11.hs 0000644 0000000 0000000 00000016752 07346545000 021320 0 ustar 00 0000000 0000000 {-# LANGUAGE MultiParamTypeClasses, StandaloneDeriving, FlexibleInstances,
InterruptibleFFI, ExistentialQuantification, DeriveDataTypeable #-}
-----------------------------------------------------------------------------
-- |
-- Module : System.Taffybar.Information.SafeX11
-- Copyright : (c) Ivan A. Malison
-- License : BSD3-style (see LICENSE)
--
-- Maintainer : Ivan A. Malison
-- Stability : unstable
-- Portability : unportable
-----------------------------------------------------------------------------
module System.Taffybar.Information.SafeX11
( module Graphics.X11.Xlib
, module Graphics.X11.Xlib.Extras
, module System.Taffybar.Information.SafeX11
)
where
import Control.Concurrent
import Control.Exception
import Control.Monad
import Control.Monad.Trans.Class
import Control.Monad.Trans.Maybe (MaybeT(..))
import Data.Either.Combinators
import Data.Typeable
import Foreign hiding (void)
import Foreign.C.Types
import GHC.ForeignPtr
import Graphics.X11.Xlib
import Graphics.X11.Xlib.Extras
hiding (rawGetWindowProperty, getWindowProperty8,
getWindowProperty16, getWindowProperty32,
xGetWMHints, getWMHints, refreshKeyboardMapping)
import Prelude
import System.IO.Unsafe
import System.Log.Logger
import System.Timeout
import Text.Printf
logHere :: Priority -> String -> IO ()
logHere = logM "System.Taffybar.Information.SafeX11"
foreign import ccall safe "XlibExtras.h XGetWMHints"
safeXGetWMHints :: Display -> Window -> IO (Ptr WMHints)
foreign import ccall interruptible "XlibExtras.h XGetWindowProperty"
safeXGetWindowProperty ::
Display ->
Window ->
Atom ->
CLong ->
CLong ->
Bool ->
Atom ->
Ptr Atom ->
Ptr CInt ->
Ptr CULong ->
Ptr CULong ->
Ptr (Ptr CUChar) -> IO Status
rawGetWindowPropertyBytes
:: Storable a
=> Int -> Display -> Atom -> Window -> IO (Maybe (ForeignPtr a, Int))
rawGetWindowPropertyBytes bits d atom w =
alloca $ \actual_type_return ->
alloca $ \actual_format_return ->
alloca $ \nitems_return ->
alloca $ \bytes_after_return ->
alloca $ \prop_return -> do
ret <- postX11RequestSync $
safeXGetWindowProperty
d
w
atom
0
0xFFFFFFFF
False
anyPropertyType
actual_type_return
actual_format_return
nitems_return
bytes_after_return
prop_return
if fromRight (-1) ret /= 0
then return Nothing
else do
prop_ptr <- peek prop_return
actual_format <- fromIntegral `fmap` peek actual_format_return
nitems <- fromIntegral `fmap` peek nitems_return
getprop prop_ptr nitems actual_format
where
getprop prop_ptr nitems actual_format
| actual_format == 0 = return Nothing -- Property not found
| actual_format /= bits = xFree prop_ptr >> return Nothing
| otherwise = do
ptr <- newConcForeignPtr (castPtr prop_ptr) (void $ xFree prop_ptr)
return $ Just (ptr, nitems)
data SafeX11Exception = SafeX11Exception deriving (Show, Eq, Typeable)
instance Exception SafeX11Exception
data IORequest = forall a. IORequest
{ ioAction :: IO a
, ioResponse :: Chan (Either SafeX11Exception a)
}
{-# NOINLINE requestQueue #-}
requestQueue :: Chan IORequest
requestQueue = unsafePerformIO newChan
{-# NOINLINE x11Thread #-}
x11Thread :: ThreadId
x11Thread = unsafePerformIO $ forkIO startHandlingX11Requests
withErrorHandler :: XErrorHandler -> IO a -> IO a
withErrorHandler new_handler action = do
handler <- mkXErrorHandler (\d e -> new_handler d e >> return 0)
original <- _xSetErrorHandler handler
res <- action
_ <- _xSetErrorHandler original
return res
deriving instance Show ErrorEvent
startHandlingX11Requests :: IO ()
startHandlingX11Requests =
withErrorHandler handleError handleX11Requests
where handleError _ xerrptr = do
ee <- getErrorEvent xerrptr
logHere WARNING $
printf "Handling X11 error with error handler: %s" $ show ee
handleX11Requests :: IO ()
handleX11Requests = do
IORequest {ioAction = action, ioResponse = responseChannel} <-
readChan requestQueue
res <-
catch
(maybe (Left SafeX11Exception) Right <$> timeout 500000 action)
(\e -> do
logHere WARNING $ printf "Handling X11 error with catch: %s" $
show (e :: IOException)
return $ Left SafeX11Exception)
writeChan responseChannel res
handleX11Requests
return ()
postX11RequestSync :: IO a -> IO (Either SafeX11Exception a)
postX11RequestSync action = do
let postAndWait = do
responseChannel <- newChan :: IO (Chan (Either SafeX11Exception a))
writeChan
requestQueue
IORequest {ioAction = action, ioResponse = responseChannel}
readChan responseChannel
currentTID <- myThreadId
if currentTID == x11Thread
then Right <$> action
else postAndWait
postX11RequestSyncDef :: a -> IO a -> IO a
postX11RequestSyncDef def action =
fromRight def <$> postX11RequestSync action
rawGetWindowProperty ::
Storable a
=> Int -> Display -> Atom -> Window -> IO (Maybe [a])
rawGetWindowProperty bits d atom w =
runMaybeT $ do
(ptr, count) <- MaybeT $ rawGetWindowPropertyBytes bits d atom w
lift $ withForeignPtr ptr $ peekArray count
getWindowProperty8 :: Display -> Atom -> Window -> IO (Maybe [CChar])
getWindowProperty8 = rawGetWindowProperty 8
getWindowProperty16 :: Display -> Atom -> Window -> IO (Maybe [CShort])
getWindowProperty16 = rawGetWindowProperty 16
getWindowProperty32 :: Display -> Atom -> Window -> IO (Maybe [CLong])
getWindowProperty32 = rawGetWindowProperty 32
getWMHints :: Display -> Window -> IO WMHints
getWMHints dpy w = do
p <- safeXGetWMHints dpy w
if p == nullPtr
then return $ WMHints 0 False 0 0 0 0 0 0 0
else do x <- peek p; _ <- xFree p; return x
safeGetGeometry :: Display -> Drawable ->
IO (Window, Position, Position, Dimension, Dimension, Dimension, CInt)
safeGetGeometry display d =
outParameters7 (throwIfZero "getGeometry") $
xGetGeometry display d
outParameters7 :: (Storable a, Storable b, Storable c, Storable d, Storable e, Storable f, Storable g) =>
(IO r -> IO ()) -> (Ptr a -> Ptr b -> Ptr c -> Ptr d -> Ptr e -> Ptr f -> Ptr g -> IO r) ->
IO (a,b,c,d,e,f,g)
outParameters7 check fn =
alloca $ \ a_return ->
alloca $ \ b_return ->
alloca $ \ c_return ->
alloca $ \ d_return ->
alloca $ \ e_return ->
alloca $ \ f_return ->
alloca $ \ g_return -> do
check (fn a_return b_return c_return d_return e_return f_return g_return)
a <- peek a_return
b <- peek b_return
c <- peek c_return
d <- peek d_return
e <- peek e_return
f <- peek f_return
g <- peek g_return
return (a,b,c,d,e,f,g)
foreign import ccall safe "HsXlib.h XGetGeometry"
xGetGeometry :: Display -> Drawable ->
Ptr Window -> Ptr Position -> Ptr Position -> Ptr Dimension ->
Ptr Dimension -> Ptr Dimension -> Ptr CInt -> IO Status
taffybar-4.0.1/src/System/Taffybar/Information/StreamInfo.hs 0000644 0000000 0000000 00000006354 07346545000 022214 0 ustar 00 0000000 0000000 --------------------------------------------------------------------------------
-- |
-- Module : System.Taffybar.Information.StreamInfo
-- Copyright : (c) José A. Romero L.
-- License : BSD3-style (see LICENSE)
--
-- Maintainer : José A. Romero L.
-- Stability : unstable
-- Portability : unportable
--
-- Generic code to poll any of the many data files maintained by the kernel in
-- POSIX systems. Provides methods for applying a custom parsing function to the
-- contents of the file and to calculate differentials across one or more values
-- provided via the file.
--
--------------------------------------------------------------------------------
module System.Taffybar.Information.StreamInfo
( getParsedInfo
, getLoad
, getAccLoad
, getTransfer
) where
import Control.Concurrent ( threadDelay )
import Data.IORef
import Data.Maybe ( fromMaybe )
-- | Apply the given parser function to the file under the given path to produce
-- a lookup map, then use the given selector as key to extract from it the
-- desired value.
getParsedInfo :: FilePath -> (String -> [(String, [a])]) -> String -> IO [a]
getParsedInfo path parser selector = do
file <- readFile path
length file `seq` return ()
return (fromMaybe [] $ lookup selector $ parser file)
truncVal :: (RealFloat a) => a -> a
truncVal v
| isNaN v || v < 0.0 = 0.0
| otherwise = v
-- | Convert the given list of Integer to a list of the ratios of each of its
-- elements against their sum.
toRatioList :: (Integral a, RealFloat b) => [a] -> [b]
toRatioList deltas = map truncVal ratios
where total = fromIntegral $ sum deltas
ratios = map ((/total) . fromIntegral) deltas
-- | Execute the given action twice with the given delay in-between and return
-- the difference between the two samples.
probe :: (Num a, RealFrac b) => IO [a] -> b -> IO [a]
probe action delay = do
a <- action
threadDelay $ round (delay * 1e6)
b <- action
return $ zipWith (-) b a
-- | Execute the given action once and return the difference between the
-- obtained sample and the one contained in the given IORef.
accProbe :: (Num a) => IO [a] -> IORef [a] -> IO [a]
accProbe action sample = do
a <- readIORef sample
b <- action
writeIORef sample b
return $ zipWith (-) b a
-- | Probe the given action and, interpreting the result as a variation in time,
-- return the speed of change of its values.
getTransfer :: (Integral a, RealFloat b) => b -> IO [a] -> IO [b]
getTransfer interval action = do
deltas <- probe action interval
return $ map (truncVal . (/interval) . fromIntegral) deltas
-- | Probe the given action and return the relative variation of each of the
-- obtained values against the whole, where the whole is calculated as the sum
-- of all the values in the probe.
getLoad :: (Integral a, RealFloat b) => b -> IO [a] -> IO [b]
getLoad interval action = toRatioList <$> probe action interval
-- | Similar to getLoad, but execute the given action only once and use the
-- given IORef to calculate the result and to save the current value, so it
-- can be reused in the next call.
getAccLoad :: (Integral a, RealFloat b) => IORef [a] -> IO [a] -> IO [b]
getAccLoad sample action = toRatioList <$> accProbe action sample
taffybar-4.0.1/src/System/Taffybar/Information/X11DesktopInfo.hs 0000644 0000000 0000000 00000024163 07346545000 022662 0 ustar 00 0000000 0000000 -----------------------------------------------------------------------------
-- |
-- Module : System.Taffybar.Information.X11DesktopInfo
-- Copyright : (c) José A. Romero L.
-- License : BSD3-style (see LICENSE)
--
-- Maintainer : Ivan Malison
-- Stability : unstable
-- 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
-- being installed in your @~\/.xmonad\/xmonad.hs@ configuration:
--
-- > import System.Taffybar.Support.PagerHints (pagerHints)
-- >
-- > main = xmonad $ ewmh $ pagerHints $ ...
--
-----------------------------------------------------------------------------
module System.Taffybar.Information.X11DesktopInfo
( X11Context(..)
, X11Property
, X11Window
, doLowerWindow
, eventLoop
, fetch
, getAtom
, getDefaultCtx
, getDisplay
, getPrimaryOutputNumber
, getVisibleTags
, isWindowUrgent
, postX11RequestSyncProp
, readAsInt
, readAsListOfInt
, readAsListOfString
, readAsListOfWindow
, readAsString
, 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
import Control.Monad.IO.Class
import Control.Monad.Trans.Class
import Control.Monad.Trans.Reader
import Data.Bits (testBit, (.|.))
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
data X11Context = X11Context
{ contextDisplay :: Display
, _contextRoot :: Window
, atomCache :: MV.MVar [(String, Atom)]
}
type X11Property a = ReaderT X11Context IO a
type X11Window = Window
type PropertyFetcher a = Display -> Atom -> Window -> IO (Maybe [a])
-- | Put the current display and root window objects inside a Reader transformer
-- for further computation.
withDefaultCtx :: X11Property a -> IO a
withDefaultCtx fun = do
ctx <- getDefaultCtx
res <- runReaderT fun ctx
closeDisplay (contextDisplay ctx)
return res
-- | An X11Property that returns the @Display@ object stored in the X11Context.
getDisplay :: X11Property Display
getDisplay = contextDisplay <$> ask
doRead :: Integral a => b -> ([a] -> b)
-> PropertyFetcher a
-> Maybe X11Window
-> String
-> X11Property b
doRead def transform windowPropFn window name =
(fromMaybe def) . (fmap 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,
-- then return -1.
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
-- | 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
-- return an empty list.
readAsListOfInt :: Maybe X11Window -- ^ window to read from. Nothing means the root window.
-> String -- ^ name of the property to retrieve
-> X11Property [Int]
readAsListOfInt = doRead [] (map fromIntegral) getWindowProperty32
-- | Retrieve the property of the given window (or the root window, if Nothing)
-- with the given name as a String. If the property hasn't been set, then return
-- an empty string.
readAsString :: Maybe X11Window -- ^ window to read from. Nothing means the root window.
-> String -- ^ name of the property to retrieve
-> X11Property String
readAsString = doRead "" (UTF8.decode . map fromIntegral) getWindowProperty8
-- | Retrieve the property of the given window (or the root window, if Nothing)
-- with the given name as a list of Strings. If the property hasn't been set,
-- then return an empty list.
readAsListOfString :: Maybe X11Window -- ^ window to read from. Nothing means the root window.
-> String -- ^ name of the property to retrieve
-> X11Property [String]
readAsListOfString = doRead [] parse getWindowProperty8
where parse = endBy "\0" . UTF8.decode . map fromIntegral
-- | Retrieve the property of the given window (or the root window, if Nothing)
-- with the given name as a list of X11 Window IDs. If the property hasn't been
-- set, then return an empty list.
readAsListOfWindow :: Maybe X11Window -- ^ window to read from. Nothing means the root window.
-> String -- ^ name of the property to retrieve
-> X11Property [X11Window]
readAsListOfWindow = doRead [] (map fromIntegral) getWindowProperty32
-- | Determine whether the \"urgent\" flag is set in the WM_HINTS of the given
-- window.
isWindowUrgent :: X11Window -> X11Property Bool
isWindowUrgent window = do
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.
getVisibleTags :: X11Property [String]
getVisibleTags = readAsListOfString Nothing "_XMONAD_VISIBLE_WORKSPACES"
-- | Return the Atom with the given name.
getAtom :: String -> X11Property Atom
getAtom s = do
(X11Context d _ cacheVar) <- ask
a <- lift $ lookup s <$> MV.readMVar cacheVar
let updateCacheAction = lift $ MV.modifyMVar cacheVar updateCache
updateCache currentCache =
do
atom <- internAtom d s False
return ((s, atom):currentCache, atom)
maybe updateCacheAction return a
-- | Spawn a new thread and listen inside it to all incoming events, invoking
-- the given function to every event of type @MapNotifyEvent@ that arrives, and
-- subscribing to all events of this type emitted by newly created windows.
eventLoop :: (Event -> IO ()) -> X11Property ()
eventLoop dispatch = do
(X11Context d w _) <- ask
liftIO $ do
selectInput d w $ propertyChangeMask .|. substructureNotifyMask
allocaXEvent $ \e -> forever $ do
event <- nextEvent d e >> getEvent e
case event of
MapNotifyEvent { ev_window = window } ->
selectInput d window propertyChangeMask
_ -> return ()
dispatch event
-- | Emit a \"command\" event with one argument for the X server. This is used
-- to send events that can be received by event hooks in the XMonad process and
-- acted upon in that context.
sendCommandEvent :: Atom -> Atom -> X11Property ()
sendCommandEvent cmd arg = do
(X11Context dpy root _) <- ask
sendCustomEvent dpy cmd arg root root
-- | Similar to 'sendCommandEvent', but with an argument of type Window.
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.
getDefaultCtx :: IO X11Context
getDefaultCtx = do
d <- openDisplay ""
w <- rootWindow d $ defaultScreen d
cache <- MV.newMVar []
return $ X11Context d w cache
-- | Apply the given function to the given window in order to obtain the X11
-- property with the given name, or Nothing if no such property can be read.
fetch :: (Integral a)
=> PropertyFetcher a -- ^ Function to use to retrieve the property.
-> Maybe X11Window -- ^ Window to read from. Nothing means the root Window.
-> String -- ^ Name of the property to retrieve.
-> X11Property (Maybe [a])
fetch fetcher window name = do
(X11Context dpy root _) <- ask
atom <- getAtom name
liftIO $ fetcher dpy atom (fromMaybe root window)
-- | Retrieve the @WM_HINTS@ mask assigned by the X server to the given window.
fetchWindowHints :: X11Window -> X11Property WMHints
fetchWindowHints window = do
(X11Context d _ _) <- ask
liftIO $ getWMHints d window
-- | Emit an event of type @ClientMessage@ that can be listened to and consumed
-- by XMonad event hooks.
sendCustomEvent :: Display
-> Atom
-> Atom
-> X11Window
-> X11Window
-> X11Property ()
sendCustomEvent dpy cmd arg root win =
liftIO $ allocaXEvent $ \e -> do
setEventType e clientMessage
setClientMessageEvent e win cmd 32 arg currentTime
sendEvent dpy root False structureNotifyMask e
sync dpy False
-- | Post the provided X11Property to taffybar's dedicated X11 thread, and wait
-- for the result. The provided default value will be returned in the case of an
-- error.
postX11RequestSyncProp :: X11Property a -> a -> X11Property a
postX11RequestSyncProp prop def = do
c <- ask
let action = runReaderT prop c
lift $ postX11RequestSyncDef def action
-- | 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.
getActiveOutputs :: X11Property [RROutput]
getActiveOutputs = do
(X11Context display rootw _) <- ask
maybeSres <- liftIO $ xrrGetScreenResources display rootw
maybe (return []) (\sres -> filterM (isActiveOutput sres) $ xrr_sr_outputs sres)
maybeSres
-- | Get the index of the primary monitor as set and ordered by Xrandr.
getPrimaryOutputNumber :: X11Property (Maybe Int)
getPrimaryOutputNumber = do
(X11Context display rootw _) <- ask
primary <- liftIO $ xrrGetOutputPrimary display rootw
outputs <- getActiveOutputs
return $ primary `elemIndex` outputs
-- | Move the X11Windows to the bottom of the X11 window stack.
doLowerWindow :: X11Window -> X11Property ()
doLowerWindow window =
asks contextDisplay >>= lift . flip lowerWindow window
taffybar-4.0.1/src/System/Taffybar/Information/XDG/ 0000755 0000000 0000000 00000000000 07346545000 020223 5 ustar 00 0000000 0000000 taffybar-4.0.1/src/System/Taffybar/Information/XDG/Protocol.hs 0000644 0000000 0000000 00000022723 07346545000 022366 0 ustar 00 0000000 0000000 -----------------------------------------------------------------------------
-- |
-- Module : System.Taffybar.Information.XDG.Protocol
-- Copyright : 2017 Ulf Jasper
-- License : BSD3-style (see LICENSE)
--
-- Maintainer : Ulf Jasper
-- Stability : unstable
-- Portability : unportable
--
-- Implementation of version 1.1 of the XDG "Desktop Menu
-- Specification", see
-- https://specifications.freedesktop.org/menu-spec/menu-spec-1.1.html
---- specification, see
-- See also 'MenuWidget'.
--
-----------------------------------------------------------------------------
module System.Taffybar.Information.XDG.Protocol
( XDGMenu(..)
, DesktopEntryCondition(..)
, getApplicationEntries
, getDirectoryDirs
, getPreferredLanguages
, getXDGDesktop
, getXDGMenuFilenames
, matchesCondition
, readXDGMenu
) where
import Control.Applicative
import Control.Monad
import Control.Monad.Trans.Class
import Control.Monad.Trans.Maybe
import Data.Char (toLower)
import Data.List
import Data.Maybe
import qualified Debug.Trace as D
import GHC.IO.Encoding
import Prelude
import Safe (headMay)
import System.Directory
import System.Environment
import System.Environment.XDG.DesktopEntry
import System.FilePath.Posix
import System.Log.Logger
import System.Posix.Files
import System.Taffybar.Util
import Text.XML.Light
import Text.XML.Light.Helpers
getXDGMenuPrefix :: IO (Maybe String)
getXDGMenuPrefix = lookupEnv "XDG_MENU_PREFIX"
-- | Find filename(s) of the application menu(s).
getXDGMenuFilenames
:: Maybe String -- ^ Overrides the value of the environment variable
-- XDG_MENU_PREFIX. Specifies the prefix for the menu (e.g.
-- 'Just "mate-"').
-> IO [FilePath]
getXDGMenuFilenames mMenuPrefix = do
configDirs <-
liftA2 (:) (getXdgDirectory XdgConfig "")
(getXdgDirectoryList XdgConfigDirs)
maybePrefix <- (mMenuPrefix <|>) <$> getXDGMenuPrefix
let maybeAddDash t = if last t == '-' then t else t ++ "-"
dashedPrefix = maybe "" maybeAddDash maybePrefix
return $ map ( "menus" dashedPrefix ++ "applications.menu") configDirs
-- | XDG Menu, cf. "Desktop Menu Specification".
data XDGMenu = XDGMenu
{ xmAppDir :: Maybe String
, xmDefaultAppDirs :: Bool -- Use $XDG_DATA_DIRS/applications
, xmDirectoryDir :: Maybe String
, xmDefaultDirectoryDirs :: Bool -- Use $XDG_DATA_DIRS/desktop-directories
, xmLegacyDirs :: [String]
, xmName :: String
, xmDirectory :: String
, xmOnlyUnallocated :: Bool
, xmDeleted :: Bool
, xmInclude :: Maybe DesktopEntryCondition
, xmExclude :: Maybe DesktopEntryCondition
, xmSubmenus :: [XDGMenu]
, xmLayout :: [XDGLayoutItem]
} deriving (Show)
data XDGLayoutItem =
XliFile String | XliSeparator | XliMenu String | XliMerge String
deriving(Show)
-- | Return a list of all available desktop entries for a given xdg menu.
getApplicationEntries
:: [String] -- ^ Preferred languages
-> XDGMenu
-> IO [DesktopEntry]
getApplicationEntries langs xm = do
defEntries <- if xmDefaultAppDirs xm
then do dataDirs <- getXDGDataDirs
concat <$> mapM (listDesktopEntries ".desktop" .
( "applications")) dataDirs
else return []
return $ sortBy (\de1 de2 -> compare (map toLower (deName langs de1))
(map toLower (deName langs de2))) defEntries
-- | Parse menu.
parseMenu :: Element -> Maybe XDGMenu
parseMenu elt =
let appDir = getChildData "AppDir" elt
defaultAppDirs = isJust $ getChildData "DefaultAppDirs" elt
directoryDir = getChildData "DirectoryDir" elt
defaultDirectoryDirs = isJust $ getChildData "DefaultDirectoryDirs" elt
name = fromMaybe "Name?" $ getChildData "Name" elt
dir = fromMaybe "Dir?" $ getChildData "Directory" elt
onlyUnallocated =
case ( getChildData "OnlyUnallocated" elt
, getChildData "NotOnlyUnallocated" elt) of
(Nothing, Nothing) -> False -- ?!
(Nothing, Just _) -> False
(Just _, Nothing) -> True
(Just _, Just _) -> False -- ?!
deleted = False -- FIXME
include = parseConditions "Include" elt
exclude = parseConditions "Exclude" elt
layout = parseLayout elt
subMenus = fromMaybe [] $ mapChildren "Menu" elt parseMenu
in Just
XDGMenu
{ xmAppDir = appDir
, xmDefaultAppDirs = defaultAppDirs
, xmDirectoryDir = directoryDir
, xmDefaultDirectoryDirs = defaultDirectoryDirs
, xmLegacyDirs = []
, xmName = name
, xmDirectory = dir
, xmOnlyUnallocated = onlyUnallocated
, xmDeleted = deleted
, xmInclude = include
, xmExclude = exclude
, xmSubmenus = subMenus
, xmLayout = layout -- FIXME
}
-- | Parse Desktop Entry conditions for Include/Exclude clauses.
parseConditions :: String -> Element -> Maybe DesktopEntryCondition
parseConditions key elt = case findChild (unqual key) elt of
Nothing -> Nothing
Just inc -> doParseConditions (elChildren inc)
where doParseConditions :: [Element] -> Maybe DesktopEntryCondition
doParseConditions [] = Nothing
doParseConditions [e] = parseSingleItem e
doParseConditions elts = Just $ Or $ mapMaybe parseSingleItem elts
parseSingleItem e = case qName (elName e) of
"Category" -> Just $ Category $ strContent e
"Filename" -> Just $ Filename $ strContent e
"And" -> Just $ And $ mapMaybe parseSingleItem
$ elChildren e
"Or" -> Just $ Or $ mapMaybe parseSingleItem
$ elChildren e
"Not" -> case parseSingleItem (head (elChildren e)) of
Nothing -> Nothing
Just rule -> Just $ Not rule
unknown -> D.trace ("Unknown Condition item: " ++ unknown) Nothing
-- | Combinable conditions for Include and Exclude statements.
data DesktopEntryCondition = Category String
| Filename String
| Not DesktopEntryCondition
| And [DesktopEntryCondition]
| Or [DesktopEntryCondition]
| All
| None
deriving (Read, Show, Eq)
parseLayout :: Element -> [XDGLayoutItem]
parseLayout elt = case findChild (unqual "Layout") elt of
Nothing -> []
Just lt -> mapMaybe parseLayoutItem (elChildren lt)
where parseLayoutItem :: Element -> Maybe XDGLayoutItem
parseLayoutItem e = case qName (elName e) of
"Separator" -> Just XliSeparator
"Filename" -> Just $ XliFile $ strContent e
unknown -> D.trace ("Unknown layout item: " ++ unknown) Nothing
-- | Determine whether a desktop entry fulfils a condition.
matchesCondition :: DesktopEntry -> DesktopEntryCondition -> Bool
matchesCondition de (Category cat) = deHasCategory de cat
matchesCondition de (Filename fn) = fn == deFilename de
matchesCondition de (Not cond) = not $ matchesCondition de cond
matchesCondition de (And conds) = all (matchesCondition de) conds
matchesCondition de (Or conds) = any (matchesCondition de) conds
matchesCondition _ All = True
matchesCondition _ None = False
-- | Determine locale language settings
getPreferredLanguages :: IO [String]
getPreferredLanguages = do
mLcMessages <- lookupEnv "LC_MESSAGES"
lang <- case mLcMessages of
Nothing -> lookupEnv "LANG" -- FIXME?
Just lm -> return (Just lm)
case lang of
Nothing -> return []
Just l -> return $
let woEncoding = takeWhile (/= '.') l
(language, _cm) = span (/= '_') woEncoding
(country, _m) = span (/= '@') (if null _cm then "" else tail _cm)
modifier = if null _m then "" else tail _m
in dgl language country modifier
where dgl "" "" "" = []
dgl l "" "" = [l]
dgl l c "" = [l ++ "_" ++ c, l]
dgl l "" m = [l ++ "@" ++ m, l]
dgl l c m = [l ++ "_" ++ c ++ "@" ++ m, l ++ "_" ++ c,
l ++ "@" ++ m]
-- | Determine current Desktop
getXDGDesktop :: IO String
getXDGDesktop = do
mCurDt <- lookupEnv "XDG_CURRENT_DESKTOP"
return $ fromMaybe "???" mCurDt
-- | Return desktop directories
getDirectoryDirs :: IO [FilePath]
getDirectoryDirs = do
dataDirs <- getXDGDataDirs
filterM (fileExist . ( "desktop-directories")) dataDirs
-- | Fetch menus and desktop entries and assemble the XDG menu.
readXDGMenu :: Maybe String -> IO (Maybe (XDGMenu, [DesktopEntry]))
readXDGMenu mMenuPrefix = do
setLocaleEncoding utf8
filenames <- getXDGMenuFilenames mMenuPrefix
headMay . catMaybes <$> traverse maybeMenu filenames
-- | Load and assemble the XDG menu from a specific file, if it exists.
maybeMenu :: FilePath -> IO (Maybe (XDGMenu, [DesktopEntry]))
maybeMenu filename =
ifM (doesFileExist filename)
(do
contents <- readFile filename
langs <- getPreferredLanguages
runMaybeT $ do
m <- MaybeT $ return $ parseXMLDoc contents >>= parseMenu
des <- lift $ getApplicationEntries langs m
return (m, des))
(do
logM "System.Taffybar.Information.XDG.Protocol" WARNING $
"Menu file '" ++ filename ++ "' does not exist!"
return Nothing)
taffybar-4.0.1/src/System/Taffybar/LogFormatter.hs 0000644 0000000 0000000 00000003134 07346545000 020256 0 ustar 00 0000000 0000000 -----------------------------------------------------------------------------
-- |
-- Module : System.Taffybar.LogFormatter
-- Copyright : (c) Ivan A. Malison
-- License : BSD3-style (see LICENSE)
--
-- Maintainer : Ivan A. Malison
-- Stability : unstable
-- Portability : unportable
-----------------------------------------------------------------------------
module System.Taffybar.LogFormatter where
import System.Console.ANSI
import System.Log.Formatter
import System.Log.Handler.Simple
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]
priorityToColor :: Priority -> Color
priorityToColor CRITICAL = Red
priorityToColor ALERT = Red
priorityToColor EMERGENCY = Red
priorityToColor ERROR = Red
priorityToColor WARNING = Yellow
priorityToColor NOTICE = Magenta
priorityToColor INFO = Blue
priorityToColor DEBUG = Green
reset :: String
reset = setSGRCode [Reset]
colorize :: Color -> String -> String
colorize color txt = setColor color <> txt <> reset
taffyLogFormatter :: LogFormatter a
taffyLogFormatter _ (level, msg) name =
return $ printf "%s %s - %s" colorizedPriority colorizedName msg
where priorityColor = priorityToColor level
colorizedPriority = colorize priorityColor
("[" <> show level <> "]")
colorizedName = colorize Green name
taffyLogHandler :: IO (GenericHandler Handle)
taffyLogHandler = setFormatter <$> streamHandler stderr DEBUG
where setFormatter h = h { formatter = taffyLogFormatter }
taffybar-4.0.1/src/System/Taffybar/SimpleConfig.hs 0000644 0000000 0000000 00000014767 07346545000 020246 0 ustar 00 0000000 0000000 -----------------------------------------------------------------------------
-- |
-- Module : System.Taffybar.SimpleConfig
-- Copyright : (c) Ivan A. Malison
-- License : BSD3-style (see LICENSE)
--
-- Maintainer : Ivan A. Malison
-- Stability : unstable
-- Portability : unportable
--
-- This module defines a simpler, but less flexible config system than the one
-- offered in "System.Taffybar.Context".
-----------------------------------------------------------------------------
module System.Taffybar.SimpleConfig
( SimpleTaffyConfig(..)
, Position(..)
, defaultSimpleTaffyConfig
, simpleDyreTaffybar
, simpleTaffybar
, toTaffyConfig
, useAllMonitors
, usePrimaryMonitor
, StrutSize(..)
) where
import qualified Control.Concurrent.MVar as MV
import Control.Monad
import Control.Monad.Trans.Class
import Data.Default (Default(..))
import Data.List
import Data.Maybe
import Data.Unique
import qualified GI.Gtk as Gtk
import GI.Gdk
import Graphics.UI.GIGtkStrut
import System.Taffybar.Information.X11DesktopInfo
import System.Taffybar
import qualified System.Taffybar.Context as BC (BarConfig(..), TaffybarConfig(..))
import System.Taffybar.Context hiding (TaffybarConfig(..), BarConfig(..))
import System.Taffybar.Util
-- | An ADT representing the edge of the monitor along which taffybar should be
-- displayed.
data Position = Top | Bottom deriving (Show, Eq)
-- | A configuration object whose interface is simpler than that of
-- 'TaffybarConfig'. Unless you have a good reason to use taffybar's more
-- advanced interface, you should stick to using this one.
data SimpleTaffyConfig = SimpleTaffyConfig
{
-- | The monitor number to put the bar on (default: 'usePrimaryMonitor')
monitorsAction :: TaffyIO [Int]
-- | Number of pixels to reserve for the bar (default: 30)
, barHeight :: StrutSize
-- | Number of additional pixels to reserve for the bar strut (default: 0)
, barPadding :: Int
-- | The position of the bar on the screen (default: 'Top')
, barPosition :: Position
-- | The number of pixels between widgets (default: 5)
, widgetSpacing :: Int
-- | Widget constructors whose outputs are placed at the beginning of the bar
, startWidgets :: [TaffyIO Gtk.Widget]
-- | Widget constructors whose outputs are placed in the center of the bar
, centerWidgets :: [TaffyIO Gtk.Widget]
-- | Widget constructors whose outputs are placed at the end of the bar
, endWidgets :: [TaffyIO Gtk.Widget]
-- | List of paths to CSS stylesheets that should be loaded at startup.
, cssPaths :: [FilePath]
-- | Hook to run at taffybar startup.
, startupHook :: TaffyIO ()
}
-- | Sensible defaults for most of the fields of 'SimpleTaffyConfig'. You'll
-- need to specify the widgets you want in the bar with 'startWidgets',
-- 'centerWidgets' and 'endWidgets'.
defaultSimpleTaffyConfig :: SimpleTaffyConfig
defaultSimpleTaffyConfig = SimpleTaffyConfig
{ monitorsAction = useAllMonitors
, barHeight = ScreenRatio $ 1 / 27
, barPadding = 0
, barPosition = Top
, widgetSpacing = 5
, startWidgets = []
, centerWidgets = []
, endWidgets = []
, cssPaths = []
, startupHook = return ()
}
instance Default SimpleTaffyConfig where
def = defaultSimpleTaffyConfig
-- | Convert a 'SimpleTaffyConfig' into a 'StrutConfig' that can be used with
-- gtk-strut.
toStrutConfig :: SimpleTaffyConfig -> Int -> StrutConfig
toStrutConfig SimpleTaffyConfig { barHeight = height
, barPadding = padding
, barPosition = pos
} monitor =
defaultStrutConfig
{ strutHeight = height
, strutYPadding = fromIntegral padding
, strutXPadding = fromIntegral padding
, strutAlignment = Center
, strutMonitor = Just $ fromIntegral monitor
, strutPosition =
case pos of
Top -> TopPos
Bottom -> BottomPos
}
toBarConfig :: SimpleTaffyConfig -> Int -> IO BC.BarConfig
toBarConfig config monitor = do
let strutConfig = toStrutConfig config monitor
barId <- newUnique
return
BC.BarConfig
{ BC.strutConfig = strutConfig
, BC.widgetSpacing = fromIntegral $ widgetSpacing config
, BC.startWidgets = startWidgets config
, BC.centerWidgets = centerWidgets config
, BC.endWidgets = endWidgets config
, BC.barId = barId
}
newtype SimpleBarConfigs = SimpleBarConfigs (MV.MVar [(Int, BC.BarConfig)])
-- | Convert a 'SimpleTaffyConfig' into a 'BC.TaffybarConfig' that can be used
-- with 'startTaffybar' or 'dyreTaffybar'.
toTaffyConfig :: SimpleTaffyConfig -> BC.TaffybarConfig
toTaffyConfig conf =
def
{ BC.getBarConfigsParam = configGetter
, BC.cssPaths = cssPaths conf
, BC.startupHook = startupHook conf
}
where
configGetter = do
SimpleBarConfigs configsVar <-
getStateDefault $ lift (SimpleBarConfigs <$> MV.newMVar [])
monitorNumbers <- monitorsAction conf
let lookupWithIndex barConfigs monitorNumber =
(monitorNumber, lookup monitorNumber barConfigs)
lookupAndUpdate barConfigs = do
let (alreadyPresent, toCreate) =
partition (isJust . snd) $
map (lookupWithIndex barConfigs) monitorNumbers
alreadyPresentConfigs = mapMaybe snd alreadyPresent
newlyCreated <-
mapM (forkM return (toBarConfig conf) . fst) toCreate
let result = map snd newlyCreated ++ alreadyPresentConfigs
return (barConfigs ++ newlyCreated, result)
lift $ MV.modifyMVar configsVar lookupAndUpdate
-- | Start taffybar using dyre with a 'SimpleTaffybarConfig'.
simpleDyreTaffybar :: SimpleTaffyConfig -> IO ()
simpleDyreTaffybar conf = dyreTaffybar $ toTaffyConfig conf
-- | Start taffybar with a 'SimpleTaffybarConfig'.
simpleTaffybar :: SimpleTaffyConfig -> IO ()
simpleTaffybar conf = startTaffybar $ toTaffyConfig conf
getMonitorCount :: IO Int
getMonitorCount =
fromIntegral <$> (screenGetDefault >>= maybe (return 0)
(screenGetDisplay >=> displayGetNMonitors))
-- | Supply this value for 'monitorsAction' to display the taffybar window on
-- all monitors.
useAllMonitors :: TaffyIO [Int]
useAllMonitors = lift $ do
count <- getMonitorCount
return [0..count-1]
-- | Supply this value for 'monitorsAction' to display the taffybar window only
-- on the primary monitor.
usePrimaryMonitor :: TaffyIO [Int]
usePrimaryMonitor =
return . fromMaybe 0 <$> lift (withDefaultCtx getPrimaryOutputNumber)
taffybar-4.0.1/src/System/Taffybar/Support/ 0000755 0000000 0000000 00000000000 07346545000 016770 5 ustar 00 0000000 0000000 taffybar-4.0.1/src/System/Taffybar/Support/PagerHints.hs 0000644 0000000 0000000 00000007630 07346545000 021376 0 ustar 00 0000000 0000000 -----------------------------------------------------------------------------
-- |
-- Module : System.Taffybar.Support.PagerHints
-- Copyright : (c) José A. Romero L.
-- License : BSD3-style (see LICENSE)
--
-- Maintainer : José A. Romero L.
-- Stability : unstable
-- Portability : unportable
--
-- Complements the "XMonad.Hooks.EwmhDesktops" with two additional hints
-- not contemplated by the EWMH standard:
--
-- [@_XMONAD_CURRENT_LAYOUT@] Contains a UTF-8 string with the name of the
-- windows layout currently used in the active workspace.
--
-- [@_XMONAD_VISIBLE_WORKSPACES@] Contains a list of UTF-8 strings with the
-- names of all the workspaces that are currently showed in a secondary
-- display, or an empty list if in the current installation there's only
-- one monitor.
--
-- The first hint can be set directly on the root window of the default
-- display, or indirectly via X11 events with an atom of the same
-- name. This allows both to track any changes that occur in the layout of
-- the current workspace, as well as to have it changed automatically by
-- just sending a custom event to the hook.
--
-- The second one should be considered read-only, and is set every time
-- XMonad calls its log hooks.
--
-----------------------------------------------------------------------------
module System.Taffybar.Support.PagerHints (
-- * Usage
-- $usage
pagerHints
) where
import Codec.Binary.UTF8.String (encode)
import Control.Monad
import Data.Monoid
import Foreign.C.Types (CInt)
import XMonad
import qualified XMonad.StackSet as W
-- $usage
--
-- You can use this module with the following in your @xmonad.hs@ file:
--
-- > import System.Taffybar.Support.PagerHints (pagerHints)
-- >
-- > main = xmonad $ ewmh $ pagerHints $ defaultConfig
-- > ...
-- | The \"Current Layout\" custom hint.
xLayoutProp :: X Atom
xLayoutProp = getAtom "_XMONAD_CURRENT_LAYOUT"
-- | The \"Visible Workspaces\" custom hint.
xVisibleProp :: X Atom
xVisibleProp = getAtom "_XMONAD_VISIBLE_WORKSPACES"
-- | Add support for the \"Current Layout\" and \"Visible Workspaces\" custom
-- hints to the given config.
pagerHints :: XConfig a -> XConfig a
pagerHints c = c { handleEventHook = handleEventHook c +++ pagerHintsEventHook
, logHook = logHook c +++ pagerHintsLogHook }
where x +++ y = x `mappend` y
-- | Update the current values of both custom hints.
pagerHintsLogHook :: X ()
pagerHintsLogHook = do
withWindowSet
(setCurrentLayout . description . W.layout . W.workspace . W.current)
withWindowSet
(setVisibleWorkspaces . map (W.tag . W.workspace) . W.visible)
-- | Set the value of the \"Current Layout\" custom hint to the one given.
setCurrentLayout :: String -> X ()
setCurrentLayout l = withDisplay $ \dpy -> do
r <- asks theRoot
a <- xLayoutProp
c <- getAtom "UTF8_STRING"
let l' = map fromIntegral (encode l)
io $ changeProperty8 dpy r a c propModeReplace l'
-- | Set the value of the \"Visible Workspaces\" hint to the one given.
setVisibleWorkspaces :: [String] -> X ()
setVisibleWorkspaces vis = withDisplay $ \dpy -> do
r <- asks theRoot
a <- xVisibleProp
c <- getAtom "UTF8_STRING"
let vis' = map fromIntegral $ concatMap ((++[0]) . encode) vis
io $ changeProperty8 dpy r a c propModeReplace vis'
-- | Handle all \"Current Layout\" events received from pager widgets, and
-- set the current layout accordingly.
pagerHintsEventHook :: Event -> X All
pagerHintsEventHook ClientMessageEvent {
ev_message_type = mt,
ev_data = d
} = withWindowSet $ \_ -> do
a <- xLayoutProp
when (mt == a) $ sendLayoutMessage d
return (All True)
pagerHintsEventHook _ = return (All True)
-- | Request a change in the current layout by sending an internal message
-- to XMonad.
sendLayoutMessage :: [CInt] -> X ()
sendLayoutMessage evData = case evData of
[] -> return ()
x:_ -> if x < 0
then sendMessage FirstLayout
else sendMessage NextLayout
taffybar-4.0.1/src/System/Taffybar/Util.hs 0000644 0000000 0000000 00000013740 07346545000 016572 0 ustar 00 0000000 0000000 {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE CPP #-}
-----------------------------------------------------------------------------
-- |
-- Module : System.Taffybar.Util
-- Copyright : (c) Ivan A. Malison
-- License : BSD3-style (see LICENSE)
--
-- Maintainer : Ivan A. Malison
-- Stability : unstable
-- Portability : unportable
-----------------------------------------------------------------------------
module System.Taffybar.Util where
import Conduit
import Control.Applicative
import Control.Arrow ((&&&))
import Control.Concurrent
import Control.Exception.Base
import Control.Monad
import Control.Monad.Trans.Maybe
import Control.Monad.Trans.Reader
import Data.Either.Combinators
import Data.GI.Base.GError
import Control.Exception.Enclosed (catchAny)
import qualified Data.GI.Gtk.Threading as Gtk
import Data.Maybe
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.FilePath.Posix
import System.Log.Logger
import qualified System.Process as P
import Text.Printf
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
logPrintF
:: (MonadIO m, Show t)
=> String -> Priority -> String -> t -> m ()
logPrintF logPath priority format toPrint =
liftIO $ logM logPath priority $ printf format $ show toPrint
logPrintFDebug :: (MonadIO m, Show t) => String -> String -> t -> m ()
logPrintFDebug path = logPrintF path DEBUG
infixl 4 ??
(??) :: Functor f => f (a -> b) -> a -> f b
fab ?? a = fmap ($ a) fab
{-# INLINE (??) #-}
ifM :: Monad m => m Bool -> m a -> m a -> m a
ifM cond whenTrue whenFalse =
cond >>= (\bool -> if bool then whenTrue else whenFalse)
forkM :: Monad m => (c -> m a) -> (c -> m b) -> c -> m (a, b)
forkM a b = sequenceT . (a &&& b)
maybeToEither :: b -> Maybe a -> Either b a
maybeToEither = flip maybe Right . Left
truncateString :: Int -> String -> String
truncateString n incoming
| length incoming <= n = incoming
| otherwise = take n incoming ++ "…"
truncateText :: Int -> T.Text -> T.Text
truncateText n incoming
| 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.
runCommand :: MonadIO m => FilePath -> [String] -> m (Either String String)
runCommand cmd args = liftIO $ do
(ecode, stdout, stderr) <- P.readProcessWithExitCode cmd args ""
logM "System.Taffybar.Util" INFO $
printf "Running command %s with args %s" (show cmd) (show args)
return $ case ecode of
ExitSuccess -> Right stdout
ExitFailure exitCode -> Left $ printf "Exit code %s: %s " (show exitCode) stderr
-- | Execute the provided IO action at the provided interval.
foreverWithDelay :: (MonadIO m, RealFrac d) => d -> IO () -> m ThreadId
foreverWithDelay delay action =
foreverWithVariableDelay $ safeAction >> return delay
where safeAction =
catchAny action $ \e ->
logPrintF "System.Taffybar.Util" WARNING "Error in foreverWithDelay %s" e
-- | Execute the provided IO action, and use the value it returns to decide how
-- long to wait until executing it again. The value returned by the action is
-- interpreted as a number of seconds.
foreverWithVariableDelay :: (MonadIO m, RealFrac d) => IO d -> m ThreadId
foreverWithVariableDelay action = liftIO $ forkIO $ action >>= delayThenAction
where delayThenAction delay =
threadDelay (floor $ delay * 1000000) >> action >>= delayThenAction
liftActionTaker
:: (Monad m)
=> ((a -> m a) -> m b) -> (a -> ReaderT c m a) -> ReaderT c m b
liftActionTaker actionTaker action = do
ctx <- ask
lift $ actionTaker $ flip runReaderT ctx . action
maybeTCombine
:: Monad m
=> m (Maybe a) -> m (Maybe a) -> m (Maybe a)
maybeTCombine a b = runMaybeT $ MaybeT a <|> MaybeT b
infixl 3 <||>
(<||>) ::
Monad m =>
(t -> m (Maybe a)) -> (t -> m (Maybe a)) -> t -> m (Maybe a)
a <||> b = combineOptions
where combineOptions v = maybeTCombine (a v) (b v)
infixl 3 <|||>
(<|||>)
:: Monad m
=> (t -> t1 -> m (Maybe a))
-> (t -> t1 -> m (Maybe a))
-> t
-> t1
-> m (Maybe a)
a <|||> b = combineOptions
where combineOptions v v1 = maybeTCombine (a v v1) (b v v1)
catchGErrorsAsLeft :: IO a -> IO (Either GError a)
catchGErrorsAsLeft action = catch (Right <$> action) (return . Left)
catchGErrorsAsNothing :: IO a -> IO (Maybe a)
catchGErrorsAsNothing = fmap rightToMaybe . catchGErrorsAsLeft
safePixbufNewFromFile :: FilePath -> IO (Maybe Gdk.Pixbuf)
safePixbufNewFromFile =
handleResult . catchGErrorsAsNothing . Gdk.pixbufNewFromFile
where
#if MIN_VERSION_gi_gdkpixbuf(2,0,26)
handleResult = fmap join
#else
handleResult = id
#endif
getPixbufFromFilePath :: FilePath -> IO (Maybe Gdk.Pixbuf)
getPixbufFromFilePath filepath = do
result <- safePixbufNewFromFile filepath
when (isNothing result) $
logM "System.Taffybar.WindowIcon" WARNING $
printf "Failed to load icon from filepath %s" filepath
return result
downloadURIToPath :: Request -> FilePath -> IO ()
downloadURIToPath uri filepath =
createDirectoryIfMissing True directory >>
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
q <- p x
if q
then return True
else anyM p xs
taffybar-4.0.1/src/System/Taffybar/Widget.hs 0000644 0000000 0000000 00000005527 07346545000 017104 0 ustar 00 0000000 0000000 {-# LANGUAGE CPP #-}
module System.Taffybar.Widget
( module System.Taffybar.Widget.Util
-- * "System.Taffybar.Widget.Battery"
, module System.Taffybar.Widget.Battery
-- * "System.Taffybar.Widget.CPUMonitor"
, module System.Taffybar.Widget.CPUMonitor
-- * "System.Taffybar.Widget.CommandRunner"
, module System.Taffybar.Widget.CommandRunner
#ifdef WIDGET_CRYPTO
-- * "System.Taffybar.Widget.Crypto"
, module System.Taffybar.Widget.Crypto
#endif
-- * "System.Taffybar.Widget.DiskIOMonitor"
, module System.Taffybar.Widget.DiskIOMonitor
-- * "System.Taffybar.Widget.FSMonitor"
, module System.Taffybar.Widget.FSMonitor
-- * "System.Taffybar.Widget.FreedesktopNotifications"
, module System.Taffybar.Widget.FreedesktopNotifications
-- * "System.Taffybar.Widget.Layout"
, module System.Taffybar.Widget.Layout
-- * "System.Taffybar.Widget.MPRIS2"
, module System.Taffybar.Widget.MPRIS2
-- * "System.Taffybar.Widget.NetworkGraph"
, module System.Taffybar.Widget.NetworkGraph
-- * "System.Taffybar.Widget.SNITray"
, module System.Taffybar.Widget.SNITray
-- * "System.Taffybar.Widget.SimpleClock"
, module System.Taffybar.Widget.SimpleClock
-- * "System.Taffybar.Widget.SimpleCommandButton"
, module System.Taffybar.Widget.SimpleCommandButton
-- * "System.Taffybar.Widget.Text.CPUMonitor"
, module System.Taffybar.Widget.Text.CPUMonitor
-- * "System.Taffybar.Widget.Text.MemoryMonitor"
, module System.Taffybar.Widget.Text.MemoryMonitor
-- * "System.Taffybar.Widget.Text.NetworkMonitor"
, module System.Taffybar.Widget.Text.NetworkMonitor
-- * "System.Taffybar.Widget.Weather"
, module System.Taffybar.Widget.Weather
-- * "System.Taffybar.Widget.Windows"
, module System.Taffybar.Widget.Windows
-- * "System.Taffybar.Widget.Workspaces"
, module System.Taffybar.Widget.Workspaces
-- * "System.Taffybar.Widget.XDGMenu.MenuWidget"
, module System.Taffybar.Widget.XDGMenu.MenuWidget
) where
import System.Taffybar.Widget.Battery
import System.Taffybar.Widget.CPUMonitor
import System.Taffybar.Widget.CommandRunner
#ifdef WIDGET_CRYPTO
import System.Taffybar.Widget.Crypto
#endif
import System.Taffybar.Widget.DiskIOMonitor
import System.Taffybar.Widget.FSMonitor
import System.Taffybar.Widget.FreedesktopNotifications
import System.Taffybar.Widget.Layout
import System.Taffybar.Widget.MPRIS2
import System.Taffybar.Widget.NetworkGraph
import System.Taffybar.Widget.SNITray
import System.Taffybar.Widget.SimpleClock
import System.Taffybar.Widget.SimpleCommandButton
import System.Taffybar.Widget.Text.CPUMonitor
import System.Taffybar.Widget.Text.MemoryMonitor
import System.Taffybar.Widget.Text.NetworkMonitor
import System.Taffybar.Widget.Util
import System.Taffybar.Widget.Weather
import System.Taffybar.Widget.Windows
import System.Taffybar.Widget.Workspaces
import System.Taffybar.Widget.XDGMenu.MenuWidget
taffybar-4.0.1/src/System/Taffybar/Widget/ 0000755 0000000 0000000 00000000000 07346545000 016537 5 ustar 00 0000000 0000000 taffybar-4.0.1/src/System/Taffybar/Widget/Battery.hs 0000644 0000000 0000000 00000015554 07346545000 020517 0 ustar 00 0000000 0000000 {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
-----------------------------------------------------------------------------
-- |
-- Module : System.Taffybar.Widget.Battery
-- Copyright : (c) Ivan A. Malison
-- License : BSD3-style (see LICENSE)
--
-- Maintainer : Ivan A. Malison
-- Stability : unstable
-- Portability : unportable
--
-- This module provides battery widgets that are queried using the UPower dbus
-- service. To avoid duplicating all information requests for each battery
-- widget displayed (if using a multi-head configuration or multiple battery
-- widgets), these widgets use the "BroadcastChan" based system for receiving
-- updates defined in "System.Taffybar.Information.Battery".
-----------------------------------------------------------------------------
module System.Taffybar.Widget.Battery
( batteryIconNew
, textBatteryNew
, textBatteryNewWithLabelAction
) where
import Control.Applicative
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.Reader
import Data.Default (Default(..))
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
import System.Taffybar.Util
import System.Taffybar.Widget.Generic.AutoSizeImage
import System.Taffybar.Widget.Generic.ChannelWidget
import System.Taffybar.Widget.Util hiding (themeLoadFlags)
import Text.Printf
import Text.StringTemplate
-- | Just the battery info that will be used for display (this makes combining
-- several easier).
data BatteryWidgetInfo = BWI
{ seconds :: Maybe Int64
, percent :: Int
, status :: String
} deriving (Eq, Show)
-- | Format a duration expressed as seconds to hours and minutes
formatDuration :: Maybe Int64 -> String
formatDuration Nothing = ""
formatDuration (Just secs) = let minutes = secs `div` 60
hours = minutes `div` 60
minutes' = minutes `mod` 60
in printf "%02d:%02d" hours minutes'
getBatteryWidgetInfo :: BatteryInfo -> BatteryWidgetInfo
getBatteryWidgetInfo info =
let battPctNum :: Int
battPctNum = floor (batteryPercentage info)
battTime :: Maybe Int64
battTime =
case batteryState info of
BatteryStateCharging -> Just $ batteryTimeToFull info
BatteryStateDischarging -> Just $ batteryTimeToEmpty info
_ -> Nothing
battStatus :: String
battStatus =
case batteryState info of
BatteryStateCharging -> "Charging"
BatteryStateDischarging -> "Discharging"
_ -> "✔"
in BWI {seconds = battTime, percent = battPctNum, status = battStatus}
-- | Given (maybe summarized) battery info and format: provides the string to display
formatBattInfo :: BatteryWidgetInfo -> String -> T.Text
formatBattInfo info fmt =
let tpl = newSTMP fmt
tpl' = setManyAttrib [ ("percentage", (show . percent) info)
, ("time", formatDuration (seconds info))
, ("status", status info)
] tpl
in render tpl'
-- | A simple textual battery widget. The displayed format is specified format
-- string where $percentage$ is replaced with the percentage of battery
-- remaining and $time$ is replaced with the time until the battery is fully
-- charged/discharged.
textBatteryNew :: String -> TaffyIO Widget
textBatteryNew format = textBatteryNewWithLabelAction labelSetter
where labelSetter label info = do
setBatteryStateClasses def label info
labelSetMarkup label $
formatBattInfo (getBatteryWidgetInfo info) format
data BatteryClassesConfig = BatteryClassesConfig
{ batteryHighThreshold :: Double
, batteryLowThreshold :: Double
, batteryCriticalThreshold :: Double
}
defaultBatteryClassesConfig :: BatteryClassesConfig
defaultBatteryClassesConfig =
BatteryClassesConfig
{ batteryHighThreshold = 80
, batteryLowThreshold = 20
, batteryCriticalThreshold = 5
}
instance Default BatteryClassesConfig where
def = defaultBatteryClassesConfig
setBatteryStateClasses ::
MonadIO m => BatteryClassesConfig -> Gtk.Label -> BatteryInfo -> m ()
setBatteryStateClasses config label info = do
case batteryState info of
BatteryStateCharging -> addClassIfMissing "charging" label >>
removeClassIfPresent "discharging" label
BatteryStateDischarging -> addClassIfMissing "discharging" label >>
removeClassIfPresent "charging" label
_ -> removeClassIfPresent "charging" label >>
removeClassIfPresent "discharging" label
classIf "high" $ percentage >= batteryHighThreshold config
classIf "low" $ percentage <= batteryLowThreshold config
classIf "critical" $ percentage <= batteryCriticalThreshold config
where percentage = batteryPercentage info
classIf klass condition =
if condition
then addClassIfMissing klass label
else removeClassIfPresent klass label
-- | Like `textBatteryNew` but provides a more general way to update the label
-- widget. The argument provided is an action that is used to update the text
-- label given a 'BatteryInfo' object describing the state of the battery.
textBatteryNewWithLabelAction ::
(Gtk.Label -> BatteryInfo -> TaffyIO ()) -> TaffyIO Widget
textBatteryNewWithLabelAction labelSetter = do
chan <- getDisplayBatteryChan
ctx <- ask
liftIO $ do
label <- labelNew Nothing
let updateWidget =
postGUIASync . flip runReaderT ctx . labelSetter label
void $ onWidgetRealize label $
runReaderT getDisplayBatteryInfo ctx >>= updateWidget
toWidget =<< channelWidgetNew label chan updateWidget
themeLoadFlags :: [IconLookupFlags]
themeLoadFlags = [IconLookupFlagsGenericFallback, IconLookupFlagsUseBuiltin]
batteryIconNew :: TaffyIO Widget
batteryIconNew = do
chan <- getDisplayBatteryChan
ctx <- ask
liftIO $ do
image <- imageNew
styleCtx <- widgetGetStyleContext =<< toWidget image
defaultTheme <- iconThemeGetDefault
let getCurrentBatteryIconNameString =
T.pack . batteryIconName <$> runReaderT getDisplayBatteryInfo ctx
extractPixbuf info =
fst <$> iconInfoLoadSymbolicForContext info styleCtx
setIconForSize size = do
name <- getCurrentBatteryIconNameString
iconThemeLookupIcon defaultTheme name size themeLoadFlags >>=
traverse extractPixbuf >>=
traverse (scalePixbufToSize size OrientationHorizontal)
updateImage <- autoSizeImage image setIconForSize OrientationHorizontal
toWidget =<< channelWidgetNew image chan (const $ postGUIASync updateImage)
taffybar-4.0.1/src/System/Taffybar/Widget/CPUMonitor.hs 0000644 0000000 0000000 00000003161 07346545000 021073 0 ustar 00 0000000 0000000 --------------------------------------------------------------------------------
-- |
-- Module : System.Taffybar.Widget.CPUMonitor
-- Copyright : (c) José A. Romero L.
-- License : BSD3-style (see LICENSE)
--
-- Maintainer : José A. Romero L.
-- Stability : unstable
-- Portability : unportable
--
-- Simple CPU monitor that uses a PollingGraph to visualize variations in the
-- user and system CPU times in one selected core, or in all cores available.
--
--------------------------------------------------------------------------------
module System.Taffybar.Widget.CPUMonitor where
import Control.Monad.IO.Class
import Data.IORef
import qualified GI.Gtk
import System.Taffybar.Information.CPU2 (getCPUInfo)
import System.Taffybar.Information.StreamInfo (getAccLoad)
import System.Taffybar.Widget.Generic.PollingGraph
-- | Creates a new CPU monitor. This is a PollingGraph fed by regular calls to
-- getCPUInfo, associated to an IORef used to remember the values yielded by the
-- last call to this function.
cpuMonitorNew
:: MonadIO m
=> GraphConfig -- ^ Configuration data for the Graph.
-> Double -- ^ Polling period (in seconds).
-> String -- ^ Name of the core to watch (e.g. \"cpu\", \"cpu0\").
-> m GI.Gtk.Widget
cpuMonitorNew cfg interval cpu = liftIO $ do
info <- getCPUInfo cpu
sample <- newIORef info
pollingGraphNew cfg interval $ probe sample cpu
probe :: IORef [Int] -> String -> IO [Double]
probe sample cpuName = do
load <- getAccLoad sample $ getCPUInfo cpuName
case load of
l0:l1:l2:_ -> return [ l0 + l1, l2 ] -- user, system
_ -> return []
taffybar-4.0.1/src/System/Taffybar/Widget/CommandRunner.hs 0000644 0000000 0000000 00000003441 07346545000 021645 0 ustar 00 0000000 0000000 {-# LANGUAGE OverloadedStrings #-}
--------------------------------------------------------------------------------
-- |
-- Module : System.Taffybar.Widget.CommandRunner
-- Copyright : (c) Arseniy Seroka
-- License : BSD3-style (see LICENSE)
--
-- Maintainer : Arseniy Seroka
-- Stability : unstable
-- Portability : unportable
--
-- Simple function which runs user defined command and
-- returns it's output in PollingLabel widget
--------------------------------------------------------------------------------
module System.Taffybar.Widget.CommandRunner ( commandRunnerNew ) where
import Control.Monad.IO.Class
import qualified GI.Gtk
import System.Log.Logger
import System.Taffybar.Util
import System.Taffybar.Widget.Generic.PollingLabel
import Text.Printf
import qualified Data.Text as T
-- | Creates a new command runner widget. This is a 'PollingLabel' fed by
-- regular calls to command given by argument. The results of calling this
-- function are displayed as string.
commandRunnerNew
:: MonadIO m
=> Double -- ^ Polling period (in seconds).
-> String -- ^ Command to execute. Should be in $PATH or an absolute path
-> [String] -- ^ Command argument. May be @[]@
-> T.Text -- ^ If command fails this will be displayed.
-> m GI.Gtk.Widget
commandRunnerNew interval cmd args defaultOutput =
pollingLabelNew interval $ runCommandWithDefault cmd args defaultOutput
runCommandWithDefault :: FilePath -> [String] -> T.Text -> IO T.Text
runCommandWithDefault cmd args def =
T.filter (/= '\n') <$> (runCommand cmd args >>= either logError (return . T.pack))
where logError err =
logM "System.Taffybar.Widget.CommandRunner" ERROR
(printf "Got error in CommandRunner %s" err) >> return def
taffybar-4.0.1/src/System/Taffybar/Widget/Crypto.hs 0000644 0000000 0000000 00000014136 07346545000 020360 0 ustar 00 0000000 0000000 {-# LANGUAGE TypeApplications #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE OverloadedStrings #-}
-----------------------------------------------------------------------------
-- |
-- Module : System.Taffybar.Widget.Crypto
-- Copyright : (c) Ivan A. Malison
-- License : BSD3-style (see LICENSE)
--
-- Maintainer : Ivan A. Malison
-- Stability : unstable
-- Portability : unportable
--
-- This module provides widgets for tracking the price of crypto currency
-- assets.
-----------------------------------------------------------------------------
module System.Taffybar.Widget.Crypto where
import Control.Concurrent
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.Class
import Control.Monad.Trans.Maybe
import Control.Monad.Trans.Reader
import Data.Aeson
import Data.Aeson.Types
import qualified Data.Aeson.Key as Key
import qualified Data.ByteString.Lazy as LBS
import Data.List.Split
import Data.Maybe
import Data.Proxy
import qualified Data.Text
import GHC.TypeLits
import qualified GI.GdkPixbuf.Objects.Pixbuf as Gdk
import qualified GI.Gtk as Gtk
import Network.HTTP.Simple hiding (Proxy)
import System.FilePath.Posix
import System.Taffybar.Context
import System.Taffybar.Information.Crypto hiding (symbol)
import System.Taffybar.Util
import System.Taffybar.Widget.Generic.AutoSizeImage
import System.Taffybar.Widget.Generic.ChannelWidget
import System.Taffybar.WindowIcon
import Text.Printf
-- | Extends 'cryptoPriceLabel' with an icon corresponding to the symbol of the
-- purchase crypto that will appear to the left of the price label. See the
-- docstring for 'getCryptoPixbuf' for details about how this icon is retrieved.
-- Note that automatic icon retrieval requires a coinmarketcap api key to be set
-- at taffybar startup. As with 'cryptoPriceLabel', this function must be
-- invoked with a type application with the type string that expresses the
-- symbol of the relevant token and the underlying currency in which its price
-- should be expressed. See the docstring of 'cryptoPriceLabel' for details
-- about the exact format that this string should take.
cryptoPriceLabelWithIcon :: forall a. KnownSymbol a => TaffyIO Gtk.Widget
cryptoPriceLabelWithIcon = do
label <- cryptoPriceLabel @a
let symbolPair = symbolVal (Proxy :: Proxy a)
symbol = head $ splitOn "-" symbolPair
hbox <- Gtk.boxNew Gtk.OrientationHorizontal 0
ctx <- ask
let refresh =
const $ flip runReaderT ctx $
fromMaybe <$> pixBufFromColor 10 0 <*> getCryptoPixbuf symbol
image <- autoSizeImageNew refresh Gtk.OrientationHorizontal
Gtk.containerAdd hbox image
Gtk.containerAdd hbox label
Gtk.widgetShowAll hbox
Gtk.toWidget hbox
newtype CMCAPIKey = CMCAPIKey String
-- | Set the coinmarketcap.com api key that will be used for retrieving crypto
-- icons that are not cached. This should occur before any attempts to retrieve
-- crypto icons happen. The easiest way to call this appropriately is to set it
-- as a 'startupHook'.
setCMCAPIKey :: String -> TaffyIO CMCAPIKey
setCMCAPIKey key =
getStateDefault $ return $ CMCAPIKey key
-- | Build a label that will reflect the price of some token in some currency in
-- the coingecko API. This function accepts these valuesas a type parameter with
-- kind 'String' of the form `(symbol for asset being purchased)-(currency the
-- price should be expressed in)`. For example, the product string for the price
-- of bitcoin quoted in U.S. dollars is "BTC-USD". You can invoke this function
-- by enabling the TypeApplications language extension and passing the string
-- associated with the asset that you want to track as follows:
--
-- > cryptoPriceLabel @"BTC-USD"
cryptoPriceLabel :: forall a. KnownSymbol a => TaffyIO Gtk.Widget
cryptoPriceLabel = getCryptoPriceChannel @a >>= cryptoPriceLabel'
cryptoPriceLabel' :: CryptoPriceChannel a -> TaffyIO Gtk.Widget
cryptoPriceLabel' (CryptoPriceChannel (chan, var)) = do
label <- Gtk.labelNew Nothing
let updateWidget CryptoPriceInfo { lastPrice = cryptoPrice } =
postGUIASync $ Gtk.labelSetMarkup label $
Data.Text.pack $ show cryptoPrice
void $ Gtk.onWidgetRealize label $
readMVar var >>= updateWidget
Gtk.toWidget =<< channelWidgetNew label chan updateWidget
cryptoIconsDir :: IO FilePath
cryptoIconsDir = ( "crypto_icons") <$> taffyStateDir
pathForCryptoSymbol :: String -> IO FilePath
pathForCryptoSymbol symbol =
( printf "%s.png" symbol) <$> cryptoIconsDir
-- | Retrieve a pixbuf image corresponding to the provided crypto symbol. The
-- image used will be retrieved from the file with the name `(pricesymbol).png`
-- from the directory defined by 'cryptoIconsDir'. If a file is not found there
-- and an an api key for coinmarketcap.com has been set using 'setCMCAPIKey', an
-- icon will be automatically be retrieved from coinmarketcap.com.
getCryptoPixbuf :: String -> TaffyIO (Maybe Gdk.Pixbuf)
getCryptoPixbuf = getCryptoIconFromCache <||> getCryptoIconFromCMC
getCryptoIconFromCache :: MonadIO m => String -> m (Maybe Gdk.Pixbuf)
getCryptoIconFromCache symbol = liftIO $
pathForCryptoSymbol symbol >>= safePixbufNewFromFile
getCryptoIconFromCMC :: String -> TaffyIO (Maybe Gdk.Pixbuf)
getCryptoIconFromCMC symbol =
runMaybeT $ do
CMCAPIKey cmcAPIKey <- MaybeT getState
MaybeT $ lift $ getCryptoIconFromCMC' cmcAPIKey symbol
getCryptoIconFromCMC' :: String -> String -> IO (Maybe Gdk.Pixbuf)
getCryptoIconFromCMC' cmcAPIKey symbol = do
jsonText <- getCryptoMeta cmcAPIKey symbol
let uri = getIconURIFromJSON symbol jsonText >>= parseRequest . Data.Text.unpack
path <- pathForCryptoSymbol symbol
maybe (return ()) (`downloadURIToPath` path) uri
safePixbufNewFromFile path
getIconURIFromJSON :: String -> LBS.ByteString -> Maybe Data.Text.Text
getIconURIFromJSON symbol jsonText =
decode jsonText >>= parseMaybe
((.: "data") >=> (.: Key.fromString symbol) >=> (.: "logo"))
taffybar-4.0.1/src/System/Taffybar/Widget/DiskIOMonitor.hs 0000644 0000000 0000000 00000003056 07346545000 021571 0 ustar 00 0000000 0000000 --------------------------------------------------------------------------------
-- |
-- Module : System.Taffybar.Widget.DiskIOMonitor
-- Copyright : (c) José A. Romero L.
-- License : BSD3-style (see LICENSE)
--
-- Maintainer : José A. Romero L.
-- Stability : unstable
-- Portability : unportable
--
-- Simple Disk IO monitor that uses a PollingGraph to visualize the speed of
-- read/write operations in one selected disk or partition.
--
--------------------------------------------------------------------------------
module System.Taffybar.Widget.DiskIOMonitor ( dioMonitorNew ) where
import Control.Monad.IO.Class
import qualified GI.Gtk
import System.Taffybar.Information.DiskIO ( getDiskTransfer )
import System.Taffybar.Widget.Generic.PollingGraph ( GraphConfig, pollingGraphNew )
-- | Creates a new disk IO monitor widget. This is a 'PollingGraph' fed by
-- regular calls to 'getDiskTransfer'. The results of calling this function
-- are normalized to the maximum value of the obtained probe (either read or
-- write transfer).
dioMonitorNew
:: MonadIO m
=> GraphConfig -- ^ Configuration data for the Graph.
-> Double -- ^ Polling period (in seconds).
-> String -- ^ Name of the disk or partition to watch (e.g. \"sda\", \"sdb1\").
-> m GI.Gtk.Widget
dioMonitorNew cfg pollSeconds =
pollingGraphNew cfg pollSeconds . probeDisk
probeDisk :: String -> IO [Double]
probeDisk disk = do
transfer <- getDiskTransfer disk
let top = foldr max 1.0 transfer
return $ map (/top) transfer
taffybar-4.0.1/src/System/Taffybar/Widget/FSMonitor.hs 0000644 0000000 0000000 00000003245 07346545000 020757 0 ustar 00 0000000 0000000 {-# LANGUAGE OverloadedStrings #-}
-----------------------------------------------------------------------------
-- |
-- Module : System.Taffybar.Widget.FSMonitor
-- Copyright : (c) José A. Romero L.
-- License : BSD3-style (see LICENSE)
--
-- Maintainer : José A. Romero L.
-- Stability : unstable
-- Portability : unportable
--
-- Simple text widget that monitors the current usage of selected disk
-- partitions by regularly parsing the output of the df command in Linux
-- systems.
--
-----------------------------------------------------------------------------
module System.Taffybar.Widget.FSMonitor ( fsMonitorNew ) where
import Control.Monad.IO.Class
import qualified GI.Gtk
import System.Process ( readProcess )
import System.Taffybar.Widget.Generic.PollingLabel ( pollingLabelNew )
import qualified Data.Text as T
-- | Creates a new filesystem monitor widget. It contains one 'PollingLabel'
-- that displays the data returned by the df command. The usage level of all
-- requested partitions is extracted in one single operation.
fsMonitorNew
:: MonadIO m
=> Double -- ^ Polling interval (in seconds, e.g. 500)
-> [String] -- ^ Names of the partitions to monitor (e.g. [\"\/\", \"\/home\"])
-> m GI.Gtk.Widget
fsMonitorNew interval fsList = liftIO $ do
label <- pollingLabelNew interval $ showFSInfo fsList
GI.Gtk.widgetShowAll label
GI.Gtk.toWidget label
showFSInfo :: [String] -> IO T.Text
showFSInfo fsList = do
fsOut <- readProcess "df" ("-kP":fsList) ""
let fss = map (take 2 . reverse . words) $ drop 1 $ lines fsOut
return $ T.pack $ unwords $ map ((\s -> "[" ++ s ++ "]") . unwords) fss
taffybar-4.0.1/src/System/Taffybar/Widget/FreedesktopNotifications.hs 0000644 0000000 0000000 00000025043 07346545000 024104 0 ustar 00 0000000 0000000 {-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
-- | This widget listens on DBus for freedesktop notifications
-- (). Currently it is
-- somewhat ugly, but the format is somewhat configurable.
--
-- The widget only displays one notification at a time and
-- notifications are cancellable.
--
-- The notificationDaemon thread handles new notifications
-- and cancellation requests, adding or removing the notification
-- to or from the queue. It additionally starts a timeout thread
-- for each notification added to queue.
--
-- The display thread blocks idling until it is awakened to refresh the GUI
--
-- A timeout thread is associated with a notification id.
-- It sleeps until the specific timeout and then removes every notification
-- with that id from the queue
module System.Taffybar.Widget.FreedesktopNotifications
( Notification(..)
, NotificationConfig(..)
, defaultNotificationConfig
, notifyAreaNew
) where
import BroadcastChan
import Control.Concurrent
import Control.Concurrent.STM
import Control.Monad ( forever, void )
import Control.Monad.IO.Class
import DBus
import DBus.Client
import Data.Default ( Default(..) )
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 )
import qualified Data.Text as T
import Data.Word ( Word32 )
import GI.GLib (markupEscapeText)
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
{ noteAppName :: Text
, noteReplaceId :: Word32
, noteSummary :: Text
, noteBody :: Text
, noteExpireTimeout :: Maybe Int32
, noteId :: Word32
} deriving (Show, Eq)
data NotifyState = NotifyState
{ noteWidget :: Label
, noteContainer :: Widget
, noteConfig :: NotificationConfig -- ^ The associated configuration
, noteQueue :: TVar (Seq Notification) -- ^ The queue of active notifications
, noteIdSource :: TVar Word32 -- ^ A source of fresh notification ids
, noteChan :: BroadcastChan In () -- ^ Writing to this channel wakes up the display thread
}
initialNoteState :: Widget -> Label -> NotificationConfig -> IO NotifyState
initialNoteState wrapper l cfg = do
m <- newTVarIO 1
q <- newTVarIO S.empty
ch <- newBroadcastChan
return NotifyState { noteQueue = q
, noteIdSource = m
, noteWidget = l
, noteContainer = wrapper
, noteConfig = cfg
, noteChan = ch
}
-- | Removes every notification with id 'nId' from the queue
notePurge :: NotifyState -> Word32 -> IO ()
notePurge s nId = atomically . modifyTVar' (noteQueue s) $
S.filter ((nId /=) . noteId)
-- | Removes the first (oldest) notification from the queue
noteNext :: NotifyState -> IO ()
noteNext s = atomically $ modifyTVar' (noteQueue s) aux
where
aux queue = case viewl queue of
EmptyL -> S.empty
_ :< ns -> ns
-- | Generates a fresh notification id
noteFreshId :: NotifyState -> IO Word32
noteFreshId NotifyState { noteIdSource } = atomically $ do
nId <- readTVar noteIdSource
writeTVar noteIdSource (succ nId)
return nId
--------------------------------------------------------------------------------
-- | Handles a new notification
notify :: NotifyState
-> Text -- ^ Application name
-> Word32 -- ^ Replaces id
-> Text -- ^ App icon
-> Text -- ^ Summary
-> Text -- ^ Body
-> [Text] -- ^ Actions
-> Map Text Variant -- ^ Hints
-> Int32 -- ^ Expires timeout (milliseconds)
-> IO Word32
notify s appName replaceId _ summary body _ _ timeout = do
realId <- if replaceId == 0 then noteFreshId s else return replaceId
let configTimeout = notificationMaxTimeout (noteConfig s)
realTimeout = if timeout <= 0 -- Gracefully handle out of spec negative values
then configTimeout
else case configTimeout of
Nothing -> Just timeout
Just maxTimeout -> Just (min maxTimeout timeout)
escapedSummary <- markupEscapeText summary (-1)
escapedBody <- markupEscapeText body (-1)
let n = Notification { noteAppName = appName
, noteReplaceId = replaceId
, noteSummary = escapedSummary
, noteBody = escapedBody
, noteExpireTimeout = realTimeout
, noteId = realId
}
-- Either add the new note to the queue or replace an existing note if their ids match
atomically $ do
queue <- readTVar $ noteQueue s
writeTVar (noteQueue s) $ case S.findIndexL (\n_ -> noteId n == noteId n_) queue of
Nothing -> queue |> n
Just index -> S.update index n queue
startTimeoutThread s n
wakeupDisplayThread s
return realId
-- | Handles user cancellation of a notification
closeNotification :: NotifyState -> Word32 -> IO ()
closeNotification s nId = do
notePurge s nId
wakeupDisplayThread s
notificationDaemon :: (AutoMethod f1, AutoMethod f2)
=> f1 -> f2 -> IO ()
notificationDaemon onNote onCloseNote = do
client <- connectSession
_ <- requestName client "org.freedesktop.Notifications" [nameAllowReplacement, nameReplaceExisting]
export client "/org/freedesktop/Notifications" interface
where
getServerInformation :: IO (Text, Text, Text, Text)
getServerInformation = return ("haskell-notification-daemon",
"nochair.net",
"0.0.1",
"1.1")
getCapabilities :: IO [Text]
getCapabilities = return ["body", "body-markup"]
interface = defaultInterface
{ interfaceName = "org.freedesktop.Notifications"
, interfaceMethods =
[ autoMethod "GetServerInformation" getServerInformation
, autoMethod "GetCapabilities" getCapabilities
, autoMethod "CloseNotification" onCloseNote
, autoMethod "Notify" onNote
]
}
--------------------------------------------------------------------------------
wakeupDisplayThread :: NotifyState -> IO ()
wakeupDisplayThread s = void $ writeBChan (noteChan s) ()
-- | Refreshes the GUI
displayThread :: NotifyState -> IO ()
displayThread s = do
chan <- newBChanListener (noteChan s)
forever $ do
_ <- readBChan chan
ns <- readTVarIO (noteQueue s)
postGUIASync $
if S.length ns == 0
then widgetHide (noteContainer s)
else do
labelSetMarkup (noteWidget s) $ formatMessage (noteConfig s) (toList ns)
widgetShowAll (noteContainer s)
where
formatMessage NotificationConfig {..} ns =
T.take notificationMaxLength $ notificationFormatter ns
--------------------------------------------------------------------------------
startTimeoutThread :: NotifyState -> Notification -> IO ()
startTimeoutThread s Notification {..} = case noteExpireTimeout of
Nothing -> return ()
Just timeout -> void $ forkIO $ do
threadDelay (fromIntegral timeout * 10^(3 :: Int))
notePurge s noteId
wakeupDisplayThread s
--------------------------------------------------------------------------------
data NotificationConfig = NotificationConfig
{ notificationMaxTimeout :: Maybe Int32 -- ^ Maximum time that a notification will be displayed (in seconds). Default: None
, notificationMaxLength :: Int -- ^ Maximum length displayed, in characters. Default: 100
, notificationFormatter :: [Notification] -> T.Text -- ^ Function used to format notifications, takes the notifications from first to last
}
defaultFormatter :: [Notification] -> T.Text
defaultFormatter ns =
let count = length ns
n = head ns
prefix = if count == 1
then ""
else "(" <> T.pack (show count) <> ") "
msg = if T.null (noteBody n)
then noteSummary n
else noteSummary n <> ": " <> noteBody n
in "" <> prefix <> "" <> msg
-- | The default formatter is one of
-- * Summary : Body
-- * Summary
-- * (N) Summary : Body
-- * (N) Summary
-- depending on the presence of a notification body, and where N is the number of queued notifications.
defaultNotificationConfig :: NotificationConfig
defaultNotificationConfig =
NotificationConfig { notificationMaxTimeout = Nothing
, notificationMaxLength = 100
, notificationFormatter = defaultFormatter
}
instance Default NotificationConfig where
def = defaultNotificationConfig
-- | Create a new notification area with the given configuration.
notifyAreaNew :: MonadIO m => NotificationConfig -> m Widget
notifyAreaNew cfg = liftIO $ do
frame <- frameNew Nothing
box <- boxNew OrientationHorizontal 3
textArea <- labelNew (Nothing :: Maybe Text)
button <- eventBoxNew
sep <- separatorNew OrientationHorizontal
bLabel <- labelNew (Nothing :: Maybe Text)
widgetSetName bLabel "NotificationCloseButton"
labelSetMarkup bLabel "×"
labelSetMaxWidthChars textArea (fromIntegral $ notificationMaxLength cfg)
labelSetEllipsize textArea Pango.EllipsizeModeEnd
containerAdd button bLabel
boxPackStart box textArea True True 0
boxPackStart box sep False False 0
boxPackStart box button False False 0
containerAdd frame box
widgetHide frame
w <- toWidget frame
s <- initialNoteState w textArea cfg
_ <- onWidgetButtonReleaseEvent button (userCancel s)
realizableWrapper <- boxNew OrientationHorizontal 0
boxPackStart realizableWrapper frame False False 0
widgetShow realizableWrapper
-- We can't start the dbus listener thread until we are in the GTK
-- main loop, otherwise things are prone to lock up and block
-- infinitely on an mvar. Bad stuff - only start the dbus thread
-- after the fake invisible wrapper widget is realized.
void $ onWidgetRealize realizableWrapper $ do
void $ forkIO (displayThread s)
notificationDaemon (notify s) (closeNotification s)
-- Don't show the widget by default - it will appear when needed
toWidget realizableWrapper
where
-- | Close the current note and pull up the next, if any
userCancel s _ = do
noteNext s
wakeupDisplayThread s
return True
taffybar-4.0.1/src/System/Taffybar/Widget/Generic/ 0000755 0000000 0000000 00000000000 07346545000 020113 5 ustar 00 0000000 0000000 taffybar-4.0.1/src/System/Taffybar/Widget/Generic/AutoSizeImage.hs 0000644 0000000 0000000 00000015331 07346545000 023160 0 ustar 00 0000000 0000000 {-# LANGUAGE OverloadedStrings #-}
module System.Taffybar.Widget.Generic.AutoSizeImage where
import qualified Control.Concurrent.MVar as MV
import Control.Monad
import Control.Monad.IO.Class
import Data.Int
import Data.Maybe
import qualified Data.Text as T
import qualified GI.Gdk as Gdk
import GI.GdkPixbuf.Objects.Pixbuf as Gdk
import qualified GI.Gtk as Gtk
import StatusNotifier.Tray (scalePixbufToSize)
import System.Log.Logger
import System.Taffybar.Util
import System.Taffybar.Widget.Util
import Text.Printf
imageLog :: Priority -> String -> IO ()
imageLog = logM "System.Taffybar.Widget.Generic.AutoSizeImage"
borderFunctions :: [Gtk.StyleContext -> [Gtk.StateFlags] -> IO Gtk.Border]
borderFunctions =
[ Gtk.styleContextGetPadding
, Gtk.styleContextGetMargin
, Gtk.styleContextGetBorder
]
data BorderInfo = BorderInfo
{ borderTop :: Int16
, borderBottom :: Int16
, borderLeft :: Int16
, borderRight :: Int16
} deriving (Show, Eq)
borderInfoZero :: BorderInfo
borderInfoZero = BorderInfo 0 0 0 0
borderWidth, borderHeight :: BorderInfo -> Int16
borderWidth borderInfo = borderLeft borderInfo + borderRight borderInfo
borderHeight borderInfo = borderTop borderInfo + borderBottom borderInfo
toBorderInfo :: (MonadIO m) => Gtk.Border -> m BorderInfo
toBorderInfo border =
BorderInfo
<$> Gtk.getBorderTop border
<*> Gtk.getBorderBottom border
<*> Gtk.getBorderLeft border
<*> Gtk.getBorderRight border
addBorderInfo :: BorderInfo -> BorderInfo -> BorderInfo
addBorderInfo
(BorderInfo t1 b1 l1 r1)
(BorderInfo t2 b2 l2 r2)
= BorderInfo (t1 + t2) (b1 + b2) (l1 + l2) (r1 + r2)
-- | Get the total size of the border (the sum of its assigned margin, border
-- and padding values) that will be drawn for a widget as a "BorderInfo" record.
getBorderInfo :: (MonadIO m, Gtk.IsWidget a) => a -> m BorderInfo
getBorderInfo widget = liftIO $ do
stateFlags <- Gtk.widgetGetStateFlags widget
styleContext <- Gtk.widgetGetStyleContext widget
let getBorderInfoFor borderFn =
borderFn styleContext stateFlags >>= toBorderInfo
combineBorderInfo lastSum fn =
addBorderInfo lastSum <$> getBorderInfoFor fn
foldM combineBorderInfo borderInfoZero borderFunctions
-- | Get the actual allocation for a "Gtk.Widget", accounting for the size of
-- its CSS assined margin, border and padding values.
getContentAllocation
:: (MonadIO m, Gtk.IsWidget a)
=> a -> BorderInfo -> m Gdk.Rectangle
getContentAllocation widget borderInfo = do
allocation <- Gtk.widgetGetAllocation widget
currentWidth <- Gdk.getRectangleWidth allocation
currentHeight <- Gdk.getRectangleHeight allocation
currentX <- Gdk.getRectangleX allocation
currentY <- Gdk.getRectangleX allocation
Gdk.setRectangleWidth allocation $ max 1 $
currentWidth - fromIntegral (borderWidth borderInfo)
Gdk.setRectangleHeight allocation $ max 1 $
currentHeight - fromIntegral (borderHeight borderInfo)
Gdk.setRectangleX allocation $
currentX + fromIntegral (borderLeft borderInfo)
Gdk.setRectangleY allocation $
currentY + fromIntegral (borderTop borderInfo)
return allocation
-- | Automatically update the "Gdk.Pixbuf" of a "Gtk.Image" using the provided
-- action whenever the "Gtk.Image" is allocated. Returns an action that forces a
-- refresh of the image through the provided action.
autoSizeImage
:: MonadIO m
=> Gtk.Image
-> (Int32 -> IO (Maybe Gdk.Pixbuf))
-> Gtk.Orientation
-> m (IO ())
autoSizeImage image getPixbuf orientation = liftIO $ do
case orientation of
Gtk.OrientationHorizontal -> Gtk.widgetSetVexpand image True
_ -> Gtk.widgetSetHexpand image True
_ <- widgetSetClassGI image "auto-size-image"
lastAllocation <- MV.newMVar 0
-- XXX: Gtk seems to report information about padding etc inconsistently,
-- which is why we look it up once, at startup. This means that we won't
-- properly react to changes to these values, which could be a pretty nasty
-- gotcha for someone down the line. :(
borderInfo <- getBorderInfo image
let setPixbuf force allocation = do
_width <- Gdk.getRectangleWidth allocation
_height <- Gdk.getRectangleHeight allocation
let width = max 1 $ _width - fromIntegral (borderWidth borderInfo)
height = max 1 $ _height - fromIntegral (borderHeight borderInfo)
size =
case orientation of
Gtk.OrientationHorizontal -> height
_ -> width
previousSize <- MV.readMVar lastAllocation
when (size /= previousSize || force) $ do
MV.modifyMVar_ lastAllocation $ const $ return size
pixbuf <- getPixbuf size
pbWidth <- fromMaybe 0 <$> traverse Gdk.getPixbufWidth pixbuf
pbHeight <- fromMaybe 0 <$> traverse Gdk.getPixbufHeight pixbuf
let pbSize = case orientation of
Gtk.OrientationHorizontal -> pbHeight
_ -> pbWidth
logLevel = if pbSize <= size then DEBUG else WARNING
imageLog logLevel $
printf "Allocating image: size %s, width %s, \
\ height %s, aw: %s, ah: %s, pbw: %s pbh: %s"
(show size)
(show width)
(show height)
(show _width)
(show _height)
(show pbWidth)
(show pbHeight)
Gtk.imageSetFromPixbuf image pixbuf
postGUIASync $ Gtk.widgetQueueResize image
_ <- Gtk.onWidgetSizeAllocate image $ setPixbuf False
return $ Gtk.widgetGetAllocation image >>= setPixbuf True
-- | Make a new "Gtk.Image" and call "autoSizeImage" on it. Automatically scale
-- the "Gdk.Pixbuf" returned from the provided getter to the appropriate size
-- using "scalePixbufToSize".
autoSizeImageNew
:: MonadIO m
=> (Int32 -> IO Gdk.Pixbuf) -> Gtk.Orientation -> m Gtk.Image
autoSizeImageNew getPixBuf orientation = do
image <- Gtk.imageNew
void $ autoSizeImage image
(\size -> Just <$> (getPixBuf size >>= scalePixbufToSize size orientation))
orientation
return image
-- | Make a new "Gtk.MenuItem" that has both a label and an icon.
imageMenuItemNew
:: MonadIO m
=> T.Text -> (Int32 -> IO (Maybe Gdk.Pixbuf)) -> m Gtk.MenuItem
imageMenuItemNew labelText pixbufGetter = do
box <- Gtk.boxNew Gtk.OrientationHorizontal 0
label <- Gtk.labelNew $ Just labelText
image <- Gtk.imageNew
void $ autoSizeImage image pixbufGetter Gtk.OrientationHorizontal
item <- Gtk.menuItemNew
Gtk.containerAdd box image
Gtk.containerAdd box label
Gtk.containerAdd item box
Gtk.widgetSetHalign box Gtk.AlignStart
Gtk.widgetSetHalign image Gtk.AlignStart
Gtk.widgetSetValign box Gtk.AlignFill
return item
taffybar-4.0.1/src/System/Taffybar/Widget/Generic/ChannelGraph.hs 0000644 0000000 0000000 00000001670 07346545000 023005 0 ustar 00 0000000 0000000 module System.Taffybar.Widget.Generic.ChannelGraph where
import BroadcastChan
import Control.Concurrent
import Control.Monad
import Control.Monad.IO.Class
import Data.Foldable (traverse_)
import GI.Gtk
import System.Taffybar.Widget.Generic.Graph
-- | Given a 'BroadcastChan' and an action to consume that broadcast chan and
-- turn it into graphable values, build a graph that will update as values are
-- broadcast over the channel.
channelGraphNew
:: MonadIO m
=> GraphConfig -> BroadcastChan In a -> (a -> IO [Double]) -> m GI.Gtk.Widget
channelGraphNew config chan sampleBuilder = do
(graphWidget, graphHandle) <- graphNew config
_ <- onWidgetRealize graphWidget $ do
ourChan <- newBChanListener chan
sampleThread <- forkIO $ forever $
readBChan ourChan >>=
traverse_ (graphAddSample graphHandle <=< sampleBuilder)
void $ onWidgetUnrealize graphWidget $ killThread sampleThread
return graphWidget
taffybar-4.0.1/src/System/Taffybar/Widget/Generic/ChannelWidget.hs 0000644 0000000 0000000 00000001501 07346545000 023160 0 ustar 00 0000000 0000000 module System.Taffybar.Widget.Generic.ChannelWidget where
import BroadcastChan
import Control.Concurrent
import Control.Monad
import Control.Monad.IO.Class
import Data.Foldable (traverse_)
import GI.Gtk
-- | Given a widget, a 'BroadcastChan' and a function that consumes the values
-- yielded by the channel that is in 'IO', connect the function to the
-- 'BroadcastChan' on a dedicated haskell thread.
channelWidgetNew ::
(MonadIO m, IsWidget w) =>
w -> BroadcastChan In a -> (a -> IO ()) -> m w
channelWidgetNew widget channel updateWidget = do
void $ onWidgetRealize widget $ do
ourChan <- newBChanListener channel
processingThreadId <- forkIO $ forever $
readBChan ourChan >>= traverse_ updateWidget
void $ onWidgetUnrealize widget $ killThread processingThreadId
widgetShowAll widget
return widget
taffybar-4.0.1/src/System/Taffybar/Widget/Generic/DynamicMenu.hs 0000644 0000000 0000000 00000001603 07346545000 022660 0 ustar 00 0000000 0000000 module System.Taffybar.Widget.Generic.DynamicMenu where
import Control.Monad.IO.Class
import qualified GI.Gtk as Gtk
data DynamicMenuConfig = DynamicMenuConfig
{ dmClickWidget :: Gtk.Widget
, dmPopulateMenu :: Gtk.Menu -> IO ()
}
dynamicMenuNew :: MonadIO m => DynamicMenuConfig -> m Gtk.Widget
dynamicMenuNew DynamicMenuConfig
{ dmClickWidget = clickWidget
, dmPopulateMenu = populateMenu
} = do
button <- Gtk.menuButtonNew
menu <- Gtk.menuNew
Gtk.containerAdd button clickWidget
Gtk.menuButtonSetPopup button $ Just menu
_ <- Gtk.onButtonPressed button $ emptyMenu menu >> populateMenu menu
Gtk.widgetShowAll button
Gtk.toWidget button
emptyMenu :: (Gtk.IsContainer a, MonadIO m) => a -> m ()
emptyMenu menu =
Gtk.containerForeach menu $ \item ->
Gtk.containerRemove menu item >> Gtk.widgetDestroy item
taffybar-4.0.1/src/System/Taffybar/Widget/Generic/Graph.hs 0000644 0000000 0000000 00000022011 07346545000 021504 0 ustar 00 0000000 0000000 {-# LANGUAGE ScopedTypeVariables #-}
-- | This is a graph widget inspired by the widget of the same name in Awesome
-- (the window manager). It plots a series of data points similarly to a bar
-- graph. This version must be explicitly fed data with 'graphAddSample'. For a
-- more automated version, see "System.Taffybar.Widgets.Generic.PollingGraph".
--
-- Like Awesome, this graph can plot multiple data sets in one widget. The data
-- sets are plotted in the order provided by the caller.
--
-- Note: all of the data fed to this widget should be in the range [0,1].
module System.Taffybar.Widget.Generic.Graph (
-- * Types
GraphHandle
, GraphConfig(..)
, GraphDirection(..)
, GraphStyle(..)
-- * Functions
, graphNew
, graphAddSample
, defaultGraphConfig
) where
import Control.Concurrent
import Control.Monad ( when )
import Control.Monad.IO.Class
import Data.Default ( Default(..) )
import Data.Foldable ( mapM_ )
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
newtype GraphHandle = GH (MVar GraphState)
data GraphState =
GraphState { graphIsBootstrapped :: Bool
, graphHistory :: [Seq Double]
, graphCanvas :: Gtk.DrawingArea
, graphConfig :: GraphConfig
}
data GraphDirection = LEFT_TO_RIGHT | RIGHT_TO_LEFT deriving (Eq)
-- 'RGBA' represents a color with a transparency.
type RGBA = (Double, Double, Double, Double)
-- | The style of the graph. Generally, you will want to draw all 'Area' graphs
-- first, and then all 'Line' graphs.
data GraphStyle
= Area -- ^ Thea area below the value is filled
| Line -- ^ The values are connected by a line (one pixel wide)
-- | The configuration options for the graph. The padding is the number of
-- pixels reserved as blank space around the widget in each direction.
data GraphConfig = GraphConfig {
-- | Number of pixels of padding on each side of the graph widget
graphPadding :: Int
-- | The background color of the graph (default black)
, graphBackgroundColor :: RGBA
-- | The border color drawn around the graph (default gray)
, graphBorderColor :: RGBA
-- | The width of the border (default 1, use 0 to disable the border)
, graphBorderWidth :: Int
-- | Colors for each data set (default cycles between red, green and blue)
, graphDataColors :: [RGBA]
-- | How to draw each data point (default @repeat Area@)
, graphDataStyles :: [GraphStyle]
-- | The number of data points to retain for each data set (default 20)
, graphHistorySize :: Int
-- | May contain Pango markup (default @Nothing@)
, graphLabel :: Maybe T.Text
-- | The width (in pixels) of the graph widget (default 50)
, graphWidth :: Int
-- | The direction in which the graph will move as time passes (default LEFT_TO_RIGHT)
, graphDirection :: GraphDirection
}
defaultGraphConfig :: GraphConfig
defaultGraphConfig =
GraphConfig
{ graphPadding = 2
, graphBackgroundColor = (0.0, 0.0, 0.0, 1.0)
, graphBorderColor = (0.5, 0.5, 0.5, 1.0)
, graphBorderWidth = 1
, graphDataColors = cycle [(1, 0, 0, 0), (0, 1, 0, 0), (0, 0, 1, 0)]
, graphDataStyles = repeat Area
, graphHistorySize = 20
, graphLabel = Nothing
, graphWidth = 50
, graphDirection = LEFT_TO_RIGHT
}
instance Default GraphConfig where
def = defaultGraphConfig
-- | Add a data point to the graph for each of the tracked data sets. There
-- should be as many values in the list as there are data sets.
graphAddSample :: GraphHandle -> [Double] -> IO ()
graphAddSample (GH mv) rawData = do
s <- readMVar mv
let drawArea = graphCanvas s
histSize = graphHistorySize (graphConfig s)
histsAndNewVals = zip pcts (graphHistory s)
newHists = case graphHistory s of
[] -> map S.singleton pcts
_ -> map (\(p,h) -> S.take histSize $ p <| h) histsAndNewVals
when (graphIsBootstrapped s) $ do
modifyMVar_ mv (\s' -> return s' { graphHistory = newHists })
postGUIASync $ Gtk.widgetQueueDraw drawArea
where
pcts = map (clamp 0 1) rawData
clamp :: Double -> Double -> Double -> Double
clamp lo hi d = max lo $ min hi d
outlineData :: (Double -> Double) -> Double -> Double -> C.Render ()
outlineData pctToY xStep pct = do
(curX,_) <- C.getCurrentPoint
C.lineTo (curX + xStep) (pctToY pct)
renderFrameAndBackground :: GraphConfig -> Int -> Int -> C.Render ()
renderFrameAndBackground cfg w h = do
let (backR, backG, backB, backA) = graphBackgroundColor cfg
(frameR, frameG, frameB, frameA) = graphBorderColor cfg
pad = graphPadding cfg
fpad = fromIntegral pad
fw = fromIntegral w
fh = fromIntegral h
-- Draw the requested background
C.setSourceRGBA backR backG backB backA
C.rectangle fpad fpad (fw - 2 * fpad) (fh - 2 * fpad)
C.fill
-- Draw a frame around the widget area (unless equal to background color,
-- which likely means the user does not want a frame)
when (graphBorderWidth cfg > 0) $ do
let p = fromIntegral (graphBorderWidth cfg)
C.setLineWidth p
C.setSourceRGBA frameR frameG frameB frameA
C.rectangle (fpad + (p / 2)) (fpad + (p / 2))
(fw - 2 * fpad - p) (fh - 2 * fpad - p)
C.stroke
renderGraph :: [Seq Double] -> GraphConfig -> Int -> Int -> Double -> C.Render ()
renderGraph hists cfg w h xStep = do
renderFrameAndBackground cfg w h
C.setLineWidth 0.1
let pad = fromIntegral $ graphPadding cfg
let framePad = fromIntegral $ graphBorderWidth cfg
-- Make the new origin be inside the frame and then scale the drawing area so
-- that all operations in terms of width and height are inside the drawn
-- frame.
C.translate (pad + framePad) (pad + framePad)
let xS = (fromIntegral w - 2 * pad - 2 * framePad) / fromIntegral w
yS = (fromIntegral h - 2 * pad - 2 * framePad) / fromIntegral h
C.scale xS yS
-- If right-to-left direction is requested, apply an horizontal inversion
-- transformation with an offset to the right equal to the width of the
-- widget.
when (graphDirection cfg == RIGHT_TO_LEFT) $
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
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
mapM_ (outlineData pctToY xStep) hist'
case style of
Area -> do
(endX, _) <- C.getCurrentPoint
C.lineTo endX (fromIntegral h)
C.lineTo 0 (fromIntegral h)
C.fill
Line -> do
C.setLineWidth 1.0
C.stroke
sequence_ $ zipWith3 renderDataSet hists (graphDataColors cfg)
(graphDataStyles cfg)
drawBorder :: MVar GraphState -> Gtk.DrawingArea -> C.Render ()
drawBorder mv drawArea = do
(w, h) <- widgetGetAllocatedSize drawArea
s <- liftIO $ readMVar mv
let cfg = graphConfig s
renderFrameAndBackground cfg w h
liftIO $ modifyMVar_ mv (\s' -> return s' { graphIsBootstrapped = True })
return ()
drawGraph :: MVar GraphState -> Gtk.DrawingArea -> C.Render ()
drawGraph mv drawArea = do
(w, h) <- widgetGetAllocatedSize drawArea
drawBorder mv drawArea
s <- liftIO $ readMVar mv
let hist = graphHistory s
cfg = graphConfig s
histSize = graphHistorySize cfg
-- Subtract 1 here since the first data point doesn't require
-- any movement in the X direction
xStep = fromIntegral w / fromIntegral (histSize - 1)
case hist of
[] -> renderFrameAndBackground cfg w h
_ -> renderGraph hist cfg w h xStep
graphNew :: MonadIO m => GraphConfig -> m (Gtk.Widget, GraphHandle)
graphNew cfg = liftIO $ do
drawArea <- Gtk.drawingAreaNew
mv <- newMVar GraphState { graphIsBootstrapped = False
, graphHistory = []
, graphCanvas = drawArea
, graphConfig = cfg
}
Gtk.widgetSetSizeRequest drawArea (fromIntegral $ graphWidth cfg) (-1)
_ <- Gtk.onWidgetDraw drawArea $ \ctx -> renderWithContext
(drawGraph mv drawArea) ctx >> return True
box <- Gtk.boxNew Gtk.OrientationHorizontal 1
Gtk.widgetSetVexpand drawArea True
Gtk.widgetSetVexpand box True
Gtk.boxPackStart box drawArea True True 0
widget <- case graphLabel cfg of
Nothing -> Gtk.toWidget box
Just labelText -> do
overlay <- Gtk.overlayNew
label <- Gtk.labelNew Nothing
Gtk.labelSetMarkup label labelText
Gtk.containerAdd overlay box
Gtk.overlayAddOverlay overlay label
Gtk.toWidget overlay
Gtk.widgetShowAll widget
return (widget, GH mv)
taffybar-4.0.1/src/System/Taffybar/Widget/Generic/Icon.hs 0000644 0000000 0000000 00000007607 07346545000 021351 0 ustar 00 0000000 0000000 -- | This is a simple static image widget, and a polling image widget that
-- updates its contents by calling a callback at a set interval.
module System.Taffybar.Widget.Generic.Icon
( iconImageWidgetNew
, iconImageWidgetNewFromName
, pollingIconImageWidgetNew
, pollingIconImageWidgetNewFromName
) where
import Control.Concurrent ( forkIO, threadDelay )
import qualified Data.Text as T
import Control.Exception as E
import Control.Monad ( forever )
import Control.Monad.IO.Class
import GI.Gtk
import System.Taffybar.Util
-- | Create a new widget that displays a static image
--
-- > iconImageWidgetNew path
--
-- returns a widget with icon at @path@.
iconImageWidgetNew :: MonadIO m => FilePath -> m Widget
iconImageWidgetNew path = liftIO $ imageNewFromFile path >>= putInBox
-- | Create a new widget that displays a static image
--
-- > iconWidgetNewFromName name
--
-- returns a widget with the icon named @name@. Icon
-- names are sourced from the current GTK theme.
iconImageWidgetNewFromName :: MonadIO m => T.Text -> m Widget
iconImageWidgetNewFromName name = liftIO $
imageNewFromIconName (Just name) (fromIntegral $ fromEnum IconSizeMenu)
>>= putInBox
-- | Create a new widget that updates itself at regular intervals. The
-- function
--
-- > pollingIconImageWidgetNew path interval cmd
--
-- returns a widget with initial icon at @path@. The widget
-- forks a thread to update its contents every @interval@ seconds.
-- The command should return a FilePath of a valid icon.
--
-- If the IO action throws an exception, it will be swallowed and the
-- label will not update until the update interval expires.
pollingIconImageWidgetNew
:: MonadIO m
=> FilePath -- ^ Initial file path of the icon
-> Double -- ^ Update interval (in seconds)
-> IO FilePath -- ^ Command to run to get the input filepath
-> m Widget
pollingIconImageWidgetNew path interval cmd =
pollingIcon interval cmd
(imageNewFromFile path)
(\image path' -> imageSetFromFile image (Just path'))
-- | Create a new widget that updates itself at regular intervals. The
-- function
--
-- > pollingIconImageWidgetNewFromName name interval cmd
--
-- returns a widget with initial icon whose name is @name@. The widget
-- forks a thread to update its contents every @interval@ seconds.
-- The command should return the name of a valid icon.
--
-- If the IO action throws an exception, it will be swallowed and the
-- label will not update until the update interval expires.
pollingIconImageWidgetNewFromName
:: MonadIO m
=> T.Text -- ^ Icon Name
-> Double -- ^ Update interval (in seconds)
-> IO T.Text -- ^ Command to run update the icon name
-> m Widget
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
:: MonadIO m
=> Double -- ^ Update Interval (in seconds)
-> 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.
-> m Widget -- ^ Polling Icon
pollingIcon interval doUpdateName doInitImage doSetImage = liftIO $ do
image <- doInitImage
_ <- onWidgetRealize image $ do
_ <- forkIO $ forever $ do
let tryUpdate = liftIO $ do
name' <- doUpdateName
postGUIASync $ doSetImage image name' >> return ()
E.catch tryUpdate ignoreIOException
threadDelay $ floor (interval * 1000000)
return ()
putInBox image
putInBox :: IsWidget child => child -> IO Widget
putInBox icon = do
box <- boxNew OrientationHorizontal 0
boxPackStart box icon False False 0
widgetShowAll box
toWidget box
ignoreIOException :: IOException -> IO ()
ignoreIOException _ = return ()
taffybar-4.0.1/src/System/Taffybar/Widget/Generic/PollingBar.hs 0000644 0000000 0000000 00000002234 07346545000 022501 0 ustar 00 0000000 0000000 -- | Like the vertical bar, but this widget automatically updates
-- itself with a callback at fixed intervals.
module System.Taffybar.Widget.Generic.PollingBar (
-- * Types
VerticalBarHandle,
BarConfig(..),
BarDirection(..),
-- * Constructors and accessors
pollingBarNew,
verticalBarFromCallback,
defaultBarConfig
) where
import Control.Concurrent
import Control.Exception.Enclosed ( tryAny )
import qualified GI.Gtk
import System.Taffybar.Widget.Util ( backgroundLoop )
import Control.Monad.IO.Class
import System.Taffybar.Widget.Generic.VerticalBar
verticalBarFromCallback :: MonadIO m
=> BarConfig -> IO Double -> m GI.Gtk.Widget
verticalBarFromCallback cfg action = liftIO $ do
(drawArea, h) <- verticalBarNew cfg
_ <- GI.Gtk.onWidgetRealize drawArea $ backgroundLoop $ do
esample <- tryAny action
traverse (verticalBarSetPercent h) esample
return drawArea
pollingBarNew :: MonadIO m
=> BarConfig -> Double -> IO Double -> m GI.Gtk.Widget
pollingBarNew cfg pollSeconds action =
liftIO $
verticalBarFromCallback cfg $ action <* delay
where delay = threadDelay $ floor (pollSeconds * 1000000)
taffybar-4.0.1/src/System/Taffybar/Widget/Generic/PollingGraph.hs 0000644 0000000 0000000 00000002776 07346545000 023051 0 ustar 00 0000000 0000000 -- | A variant of the Graph widget that automatically updates itself
-- with a callback at a fixed interval.
module System.Taffybar.Widget.Generic.PollingGraph (
-- * Types
GraphHandle,
GraphConfig(..),
GraphDirection(..),
GraphStyle(..),
-- * Constructors and accessors
pollingGraphNew,
pollingGraphNewWithTooltip,
defaultGraphConfig
) where
import Control.Concurrent
import qualified Control.Exception.Enclosed as E
import Control.Monad
import Control.Monad.IO.Class
import qualified Data.Text as T
import GI.Gtk
import System.Taffybar.Util
import System.Taffybar.Widget.Generic.Graph
pollingGraphNewWithTooltip
:: MonadIO m
=> GraphConfig -> Double -> IO ([Double], Maybe T.Text) -> m GI.Gtk.Widget
pollingGraphNewWithTooltip cfg pollSeconds action = liftIO $ do
(graphWidget, graphHandle) <- graphNew cfg
_ <- onWidgetRealize graphWidget $ do
sampleThread <- foreverWithDelay pollSeconds $ do
esample <- E.tryAny action
case esample of
Left _ -> return ()
Right (sample, tooltipStr) -> do
graphAddSample graphHandle sample
widgetSetTooltipMarkup graphWidget tooltipStr
void $ onWidgetUnrealize graphWidget $ killThread sampleThread
return graphWidget
pollingGraphNew
:: MonadIO m
=> GraphConfig -> Double -> IO [Double] -> m GI.Gtk.Widget
pollingGraphNew cfg pollSeconds action =
pollingGraphNewWithTooltip cfg pollSeconds $ fmap (, Nothing) action
taffybar-4.0.1/src/System/Taffybar/Widget/Generic/PollingLabel.hs 0000644 0000000 0000000 00000005127 07346545000 023020 0 ustar 00 0000000 0000000 -- | This is a simple text widget that updates its contents by calling
-- a callback at a set interval.
module System.Taffybar.Widget.Generic.PollingLabel where
import Control.Concurrent
import Control.Exception.Enclosed as E
import Control.Monad
import Control.Monad.IO.Class
import qualified Data.Text as T
import GI.Gtk
import System.Log.Logger
import System.Taffybar.Util
import System.Taffybar.Widget.Util
import Text.Printf
-- | Create a new widget that updates itself at regular intervals. The
-- function
--
-- > pollingLabelNew initialString cmd interval
--
-- returns a widget with initial text @initialString@. The widget forks a thread
-- to update its contents every @interval@ seconds. The command should return a
-- string with any HTML entities escaped. This is not checked by the function,
-- since Pango markup shouldn't be escaped. Proper input sanitization is up to
-- the caller.
--
-- If the IO action throws an exception, it will be swallowed and the label will
-- not update until the update interval expires.
pollingLabelNew
:: MonadIO m
=> Double -- ^ Update interval (in seconds)
-> IO T.Text -- ^ Command to run to get the input string
-> m GI.Gtk.Widget
pollingLabelNew interval cmd =
pollingLabelNewWithTooltip interval $ (, Nothing) <$> cmd
pollingLabelNewWithTooltip
:: MonadIO m
=> Double -- ^ Update interval (in seconds)
-> IO (T.Text, Maybe T.Text) -- ^ Command to run to get the input string
-> m GI.Gtk.Widget
pollingLabelNewWithTooltip interval action =
pollingLabelWithVariableDelay $ withInterval <$> action
where withInterval (a, b) = (a, b, interval)
pollingLabelWithVariableDelay
:: MonadIO m
=> IO (T.Text, Maybe T.Text, Double)
-> m GI.Gtk.Widget
pollingLabelWithVariableDelay action =
liftIO $ do
grid <- gridNew
label <- labelNew Nothing
let updateLabel (labelStr, tooltipStr, delay) = do
postGUIASync $ do
labelSetMarkup label labelStr
widgetSetTooltipMarkup label tooltipStr
logM "System.Taffybar.Widget.Generic.PollingLabel" DEBUG $
printf "Polling label delay was %s" $ show delay
return delay
updateLabelHandlingErrors =
E.tryAny action >>= either (const $ return 1) updateLabel
_ <- onWidgetRealize label $ do
sampleThread <- foreverWithVariableDelay updateLabelHandlingErrors
void $ onWidgetUnrealize label $ killThread sampleThread
vFillCenter label
vFillCenter grid
containerAdd grid label
widgetShowAll grid
toWidget grid
taffybar-4.0.1/src/System/Taffybar/Widget/Generic/VerticalBar.hs 0000644 0000000 0000000 00000014172 07346545000 022652 0 ustar 00 0000000 0000000 -- | A vertical bar that can plot data in the range [0, 1]. The
-- colors are configurable.
module System.Taffybar.Widget.Generic.VerticalBar (
-- * Types
VerticalBarHandle,
BarConfig(..),
BarDirection(..),
-- * Accessors/Constructors
verticalBarNew,
verticalBarSetPercent,
defaultBarConfig,
defaultBarConfigIO
) where
import Control.Concurrent
import Control.Monad
import Control.Monad.IO.Class
import qualified GI.Cairo.Render as C
import GI.Cairo.Render.Connector
import GI.Gtk hiding (widgetGetAllocatedSize)
import System.Taffybar.Util
import System.Taffybar.Widget.Util
newtype VerticalBarHandle = VBH (MVar VerticalBarState)
data VerticalBarState = VerticalBarState
{ barIsBootstrapped :: Bool
, barPercent :: Double
, barCanvas :: DrawingArea
, barConfig :: BarConfig
}
data BarDirection = HORIZONTAL | VERTICAL
data BarConfig
= BarConfig {
-- | Color of the border drawn around the widget
barBorderColor :: (Double, Double, Double)
-- | The background color of the widget
, barBackgroundColor :: Double -> (Double, Double, Double)
-- | A function to determine the color of the widget for the current data point
, barColor :: Double -> (Double, Double, Double)
-- | Number of pixels of padding around the widget
, barPadding :: Int
, barWidth :: Int
, barDirection :: BarDirection}
| BarConfigIO { barBorderColorIO :: IO (Double, Double, Double)
, barBackgroundColorIO :: Double -> IO (Double, Double, Double)
, barColorIO :: Double -> IO (Double, Double, Double)
, barPadding :: Int
, barWidth :: Int
, barDirection :: BarDirection}
-- | A default bar configuration. The color of the active portion of
-- the bar must be specified.
defaultBarConfig :: (Double -> (Double, Double, Double)) -> BarConfig
defaultBarConfig c =
BarConfig
{ barBorderColor = (0.5, 0.5, 0.5)
, barBackgroundColor = const (0, 0, 0)
, barColor = c
, barPadding = 2
, barWidth = 15
, barDirection = VERTICAL
}
defaultBarConfigIO :: (Double -> IO (Double, Double, Double)) -> BarConfig
defaultBarConfigIO c =
BarConfigIO
{ barBorderColorIO = return (0.5, 0.5, 0.5)
, barBackgroundColorIO = \_ -> return (0, 0, 0)
, barColorIO = c
, barPadding = 2
, barWidth = 15
, barDirection = VERTICAL
}
verticalBarSetPercent :: VerticalBarHandle -> Double -> IO ()
verticalBarSetPercent (VBH mv) pct = do
s <- readMVar mv
let drawArea = barCanvas s
when (barIsBootstrapped s) $ do
modifyMVar_ mv (\s' -> return s' { barPercent = clamp 0 1 pct })
postGUIASync $ widgetQueueDraw drawArea
clamp :: Double -> Double -> Double -> Double
clamp lo hi d = max lo $ min hi d
liftedBackgroundColor :: BarConfig -> Double -> IO (Double, Double, Double)
liftedBackgroundColor bc pct =
case bc of
BarConfig { barBackgroundColor = bcolor } -> return (bcolor pct)
BarConfigIO { barBackgroundColorIO = bcolor } -> bcolor pct
liftedBorderColor :: BarConfig -> IO (Double, Double, Double)
liftedBorderColor bc =
case bc of
BarConfig { barBorderColor = border } -> return border
BarConfigIO { barBorderColorIO = border } -> border
liftedBarColor :: BarConfig -> Double -> IO (Double, Double, Double)
liftedBarColor bc pct =
case bc of
BarConfig { barColor = c } -> return (c pct)
BarConfigIO { barColorIO = c } -> c pct
renderFrame_ :: Double -> BarConfig -> Int -> Int -> C.Render ()
renderFrame_ pct cfg width height = do
let fwidth = fromIntegral width
fheight = fromIntegral height
-- Now draw the user's requested background, respecting padding
(bgR, bgG, bgB) <- C.liftIO $ liftedBackgroundColor cfg pct
let pad = barPadding cfg
fpad = fromIntegral pad
C.setSourceRGB bgR bgG bgB
C.rectangle fpad fpad (fwidth - 2 * fpad) (fheight - 2 * fpad)
C.fill
-- Now draw a nice frame
(frameR, frameG, frameB) <- C.liftIO $ liftedBorderColor cfg
C.setSourceRGB frameR frameG frameB
C.setLineWidth 1.0
C.rectangle (fpad + 0.5) (fpad + 0.5) (fwidth - 2 * fpad - 1) (fheight - 2 * fpad - 1)
C.stroke
renderBar :: Double -> BarConfig -> Int -> Int -> C.Render ()
renderBar pct cfg width height = do
let direction = barDirection cfg
activeHeight = case direction of
VERTICAL -> pct * fromIntegral height
HORIZONTAL -> fromIntegral height
activeWidth = case direction of
VERTICAL -> fromIntegral width
HORIZONTAL -> pct * fromIntegral width
newOrigin = case direction of
VERTICAL -> fromIntegral height - activeHeight
HORIZONTAL -> 0
pad = barPadding cfg
renderFrame_ pct cfg width height
-- After we draw the frame, transform the coordinate space so that
-- we only draw within the frame.
C.translate (fromIntegral pad + 1) (fromIntegral pad + 1)
let xS = fromIntegral (width - 2 * pad - 2) / fromIntegral width
yS = fromIntegral (height - 2 * pad - 2) / fromIntegral height
C.scale xS yS
(r, g, b) <- C.liftIO $ liftedBarColor cfg pct
C.setSourceRGB r g b
C.translate 0 newOrigin
C.rectangle 0 0 activeWidth activeHeight
C.fill
drawBar :: MVar VerticalBarState -> DrawingArea -> C.Render ()
drawBar mv drawArea = do
(w, h) <- widgetGetAllocatedSize drawArea
s <- liftIO $ do
s <- readMVar mv
modifyMVar_ mv (\s' -> return s' { barIsBootstrapped = True })
return s
renderBar (barPercent s) (barConfig s) w h
verticalBarNew :: MonadIO m => BarConfig -> m (GI.Gtk.Widget, VerticalBarHandle)
verticalBarNew cfg = liftIO $ do
drawArea <- drawingAreaNew
mv <-
newMVar
VerticalBarState
{ barIsBootstrapped = False
, barPercent = 0
, barCanvas = drawArea
, barConfig = cfg
}
widgetSetSizeRequest drawArea (fromIntegral $ barWidth cfg) (-1)
_ <- onWidgetDraw drawArea $ \ctx -> renderWithContext (drawBar mv drawArea) ctx >> return True
box <- boxNew OrientationHorizontal 1
boxPackStart box drawArea True True 0
widgetShowAll box
giBox <- toWidget box
return (giBox, VBH mv)
taffybar-4.0.1/src/System/Taffybar/Widget/Layout.hs 0000644 0000000 0000000 00000007606 07346545000 020361 0 ustar 00 0000000 0000000 {-# LANGUAGE OverloadedStrings #-}
-----------------------------------------------------------------------------
-- |
-- Module : System.Taffybar.Widget.Layout
-- Copyright : (c) Ivan Malison
-- License : BSD3-style (see LICENSE)
--
-- Maintainer : Ivan Malison
-- Stability : unstable
-- Portability : unportable
--
-- Simple text widget that shows the XMonad layout used in the currently active
-- workspace, and that allows to change it by clicking with the mouse:
-- left-click to switch to the next layout in the list, right-click to switch to
-- the first one (as configured in @xmonad.hs@)
-----------------------------------------------------------------------------
module System.Taffybar.Widget.Layout
(
-- * Usage
-- $usage
LayoutConfig(..)
, defaultLayoutConfig
, layoutNew
) where
import Control.Monad.Trans.Class
import Control.Monad.Trans.Reader
import Data.Default (Default(..))
import qualified Data.Text as T
import qualified GI.Gtk as Gtk
import GI.Gdk
import System.Taffybar.Context
import System.Taffybar.Information.X11DesktopInfo
import System.Taffybar.Util
import System.Taffybar.Widget.Util
-- $usage
--
-- This widget requires that the "System.Taffybar.Support.PagerHints" hook be
-- installed in your @xmonad.hs@:
--
-- > import System.Taffybar.Support.PagerHints (pagerHints)
-- > main = do
-- > xmonad $ ewmh $ pagerHints $ defaultConfig
-- > ...
--
-- Once you've properly configured @xmonad.hs@, you can use the widget in
-- your @taffybar.hs@ file:
--
-- > import System.Taffybar.Widget.Layout
-- > main = do
-- > let los = layoutSwitcherNew def
--
-- now you can use @los@ as any other Taffybar widget.
newtype LayoutConfig = LayoutConfig
{ formatLayout :: T.Text -> TaffyIO T.Text
}
defaultLayoutConfig :: LayoutConfig
defaultLayoutConfig = LayoutConfig return
instance Default LayoutConfig where
def = defaultLayoutConfig
-- | Name of the X11 events to subscribe, and of the hint to look for for
-- the name of the current layout.
xLayoutProp :: String
xLayoutProp = "_XMONAD_CURRENT_LAYOUT"
-- | Create a new Layout widget that will use the given Pager as
-- its source of events.
layoutNew :: LayoutConfig -> TaffyIO Gtk.Widget
layoutNew config = do
ctx <- ask
label <- lift $ Gtk.labelNew (Nothing :: Maybe T.Text)
_ <- widgetSetClassGI label "layout-label"
-- This callback is run in a separate thread and needs to use
-- postGUIASync
let callback _ = liftReader postGUIASync $ do
layout <- runX11Def "" $ readAsString Nothing xLayoutProp
markup <- formatLayout config (T.pack layout)
lift $ Gtk.labelSetMarkup label markup
subscription <- subscribeToPropertyEvents [xLayoutProp] callback
do
ebox <- Gtk.eventBoxNew
Gtk.containerAdd ebox label
_ <- Gtk.onWidgetButtonPressEvent ebox $ dispatchButtonEvent ctx
Gtk.widgetShowAll ebox
_ <- Gtk.onWidgetUnrealize ebox $ flip runReaderT ctx $ unsubscribe subscription
Gtk.toWidget ebox
-- | Call 'switch' with the appropriate argument (1 for left click, -1 for
-- right click), depending on the click event received.
dispatchButtonEvent :: Context -> EventButton -> IO Bool
dispatchButtonEvent context btn = do
pressType <- getEventButtonType btn
buttonNumber <- getEventButtonButton btn
case pressType of
EventTypeButtonPress ->
case buttonNumber of
1 -> runReaderT (runX11Def () (switch 1)) context >> return True
2 -> runReaderT (runX11Def () (switch (-1))) context >> return True
_ -> return False
_ -> return False
-- | Emit a new custom event of type _XMONAD_CURRENT_LAYOUT, that can be
-- intercepted by the PagerHints hook, which in turn can instruct XMonad to
-- switch to a different layout.
switch :: Int -> X11Property ()
switch n = do
cmd <- getAtom xLayoutProp
sendCommandEvent cmd (fromIntegral n)
taffybar-4.0.1/src/System/Taffybar/Widget/MPRIS2.hs 0000644 0000000 0000000 00000025150 07346545000 020052 0 ustar 00 0000000 0000000 {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE FlexibleContexts #-}
-----------------------------------------------------------------------------
-- |
-- Module : System.Taffybar.Widget.MPRIS2
-- Copyright : (c) Ivan A. Malison
-- License : BSD3-style (see LICENSE)
--
-- Maintainer : Ivan A. Malison
-- Stability : unstable
-- Portability : unportable
--
-- This is a "Now Playing" widget that listens for MPRIS2 events on DBus. You
-- can find the MPRIS2 specification here at
-- ().
-----------------------------------------------------------------------------
module System.Taffybar.Widget.MPRIS2 where
import Control.Arrow
import qualified Control.Concurrent.MVar as MV
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.Class
import Control.Monad.Trans.Except
import Control.Monad.Trans.Reader
import DBus
import DBus.Client
import qualified DBus.TH as DBus
import Data.Default (Default(..))
import Data.GI.Base.Overloading (IsDescendantOf)
import Data.Int
import Data.List
import qualified Data.Map as M
import qualified Data.Text as T
import qualified GI.GLib as G
import GI.GdkPixbuf.Objects.Pixbuf as Gdk
import qualified GI.Gtk as Gtk
import System.Environment.XDG.DesktopEntry
import System.Log.Logger
import System.Taffybar.Context
import qualified System.Taffybar.DBus.Client.MPRIS2 as MPRIS2DBus
import System.Taffybar.Information.MPRIS2
import System.Taffybar.Util
import System.Taffybar.Widget.Generic.AutoSizeImage
import System.Taffybar.Widget.Util
import System.Taffybar.WindowIcon
import Text.Printf
mprisLog :: (MonadIO m, Show t) => Priority -> String -> t -> m ()
mprisLog = logPrintF "System.Taffybar.Widget.MPRIS2"
-- | A type representing a function that produces an IO action that adds the
-- provided widget to some container.
type WidgetAdder a m =
(IsDescendantOf Gtk.Widget a
, MonadIO m
, Gtk.GObject a
) => a -> m ()
-- | The type of a customization function that is used to update a widget with
-- the provided now playing info. The type a should be the internal state used
-- for the widget (typically just references to the child widgets that may need
-- to be updated ). When the provided value is nothing, it means that the widget
-- does not exist yet and it should be instantiated. When the provided
-- NowPlaying value is Nothing, the dbus client is no longer, and typically the
-- widget should be hidden.
type UpdateMPRIS2PlayerWidget a =
(forall w. WidgetAdder w IO) -> Maybe a -> Maybe NowPlaying -> TaffyIO a
-- | Configuration for an MPRIS2 Widget
data MPRIS2Config a =
MPRIS2Config
{
-- | A function that will be used to wrap the outer MPRIS2 grid widget
mprisWidgetWrapper :: Gtk.Widget -> IO Gtk.Widget
-- | This function will be called to instantiate and update the player widgets
-- of each dbus player client. See the docstring for `UpdateMPRIS2PlayerWidget`
-- for more details.
, updatePlayerWidget :: UpdateMPRIS2PlayerWidget a
}
defaultMPRIS2Config :: MPRIS2Config MPRIS2PlayerWidget
defaultMPRIS2Config =
MPRIS2Config
{ mprisWidgetWrapper = return
, updatePlayerWidget = simplePlayerWidget def
}
data MPRIS2PlayerWidget = MPRIS2PlayerWidget
{ playerLabel :: Gtk.Label
, playerWidget :: Gtk.Widget
}
data SimpleMPRIS2PlayerConfig = SimpleMPRIS2PlayerConfig
{ setNowPlayingLabel :: NowPlaying -> IO T.Text
, showPlayerWidgetFn :: NowPlaying -> IO Bool
}
defaultPlayerConfig :: SimpleMPRIS2PlayerConfig
defaultPlayerConfig = SimpleMPRIS2PlayerConfig
{ setNowPlayingLabel = playingText 20 30
, showPlayerWidgetFn =
\NowPlaying { npStatus = status } -> return $ status /= "Stopped"
}
instance Default SimpleMPRIS2PlayerConfig where
def = defaultPlayerConfig
makeExcept :: String -> (a -> IO (Maybe b)) -> a -> ExceptT String IO b
makeExcept errorString actionBuilder =
ExceptT . fmap (maybeToEither errorString) . actionBuilder
loadIconAtSize ::
Client -> BusName -> Int32 -> IO Gdk.Pixbuf
loadIconAtSize client busName size =
let
failure err =
mprisLog WARNING "Failed to load default image: %s" err >>
pixBufFromColor size 0
loadDefault =
loadIcon size "play.svg" >>= either failure return
logErrorAndLoadDefault err =
mprisLog WARNING "Failed to get MPRIS icon: %s" err >>
mprisLog WARNING "MPRIS failure for: %s" busName >>
loadDefault
chromeSpecialCase l@(Left _) =
if "chrom" `isInfixOf` formatBusName busName
then Right "google-chrome" else l
chromeSpecialCase x = x
in
either logErrorAndLoadDefault return =<<
runExceptT (ExceptT (left show . chromeSpecialCase <$> MPRIS2DBus.getDesktopEntry client busName)
>>= makeExcept "Failed to get desktop entry"
getDirectoryEntryDefault
>>= makeExcept "Failed to get image"
(getImageForDesktopEntry size))
-- | This is the default player widget constructor that is used to build mpris
-- widgets. It provides only an icon and NowPlaying text.
simplePlayerWidget ::
SimpleMPRIS2PlayerConfig -> UpdateMPRIS2PlayerWidget MPRIS2PlayerWidget
simplePlayerWidget _ _
(Just p@MPRIS2PlayerWidget { playerWidget = widget })
Nothing =
lift $ Gtk.widgetHide widget >> return p
simplePlayerWidget c addToParent Nothing
np@(Just NowPlaying { npBusName = busName }) = do
ctx <- ask
client <- asks sessionDBusClient
lift $ do
mprisLog DEBUG "Building widget for %s" busName
image <- autoSizeImageNew (loadIconAtSize client busName) Gtk.OrientationHorizontal
playerBox <- Gtk.gridNew
label <- Gtk.labelNew Nothing
ebox <- Gtk.eventBoxNew
_ <- Gtk.onWidgetButtonPressEvent ebox $
const $ MPRIS2DBus.playPause client busName >> return True
Gtk.containerAdd playerBox image
Gtk.containerAdd playerBox label
Gtk.containerAdd ebox playerBox
vFillCenter playerBox
addToParent ebox
Gtk.widgetSetVexpand playerBox True
Gtk.widgetSetName playerBox $ T.pack $ formatBusName busName
Gtk.widgetShowAll ebox
Gtk.widgetHide ebox
widget <- Gtk.toWidget ebox
let widgetData =
MPRIS2PlayerWidget { playerLabel = label, playerWidget = widget }
flip runReaderT ctx $
simplePlayerWidget c addToParent (Just widgetData) np
simplePlayerWidget config _
(Just w@MPRIS2PlayerWidget
{ playerLabel = label
, playerWidget = widget
}) (Just nowPlaying) = lift $ do
mprisLog DEBUG "Setting state %s" nowPlaying
Gtk.labelSetMarkup label =<< setNowPlayingLabel config nowPlaying
shouldShow <- showPlayerWidgetFn config nowPlaying
if shouldShow
then Gtk.widgetShowAll widget
else Gtk.widgetHide widget
return w
simplePlayerWidget _ _ _ _ =
mprisLog WARNING "widget update called with no widget or %s"
("nowplaying" :: String) >> return undefined
-- | Construct a new MPRIS2 widget using the `simplePlayerWidget` constructor.
mpris2New :: TaffyIO Gtk.Widget
mpris2New = mpris2NewWithConfig defaultMPRIS2Config
-- | Construct a new MPRIS2 widget with the provided configuration.
mpris2NewWithConfig :: MPRIS2Config a -> TaffyIO Gtk.Widget
mpris2NewWithConfig config = ask >>= \ctx -> asks sessionDBusClient >>= \client -> lift $ do
grid <- Gtk.gridNew
outerWidget <- Gtk.toWidget grid >>= mprisWidgetWrapper config
vFillCenter grid
playerWidgetsVar <- MV.newMVar M.empty
let
updateWidget = updatePlayerWidget config
updatePlayerWidgets nowPlayings playerWidgets = do
let
updateWidgetFromNP np@NowPlaying { npBusName = busName } =
(busName,) <$> updateWidget (Gtk.containerAdd grid)
(M.lookup busName playerWidgets) (Just np)
activeBusNames = map npBusName nowPlayings
existingBusNames = M.keys playerWidgets
inactiveBusNames = existingBusNames \\ activeBusNames
callForNoPlayingAvailable busName =
updateWidget (Gtk.containerAdd grid)
(M.lookup busName playerWidgets) Nothing
-- Invoke the widgets with no NowPlaying so they can hide etc.
mapM_ callForNoPlayingAvailable inactiveBusNames
-- Update all the other widgets
updatedWidgets <- M.fromList <$> mapM updateWidgetFromNP nowPlayings
return $ M.union updatedWidgets playerWidgets
updatePlayerWidgetsVar nowPlayings = postGUISync $
MV.modifyMVar_ playerWidgetsVar $ flip runReaderT ctx .
updatePlayerWidgets nowPlayings
setPlayingClass = do
anyVisible <- anyM Gtk.widgetIsVisible =<< Gtk.containerGetChildren grid
if anyVisible
then do
addClassIfMissing "visible-children" outerWidget
removeClassIfPresent "no-visible-children" outerWidget
else do
addClassIfMissing "no-visible-children" outerWidget
removeClassIfPresent "visible-children" outerWidget
doUpdate = do
nowPlayings <- getNowPlayingInfo client
updatePlayerWidgetsVar nowPlayings
setPlayingClass
signalCallback _ _ _ _ = doUpdate
propMatcher = matchAny { matchPath = Just "/org/mpris/MediaPlayer2" }
handleNameOwnerChanged _ name _ _ = do
playerWidgets <- MV.readMVar playerWidgetsVar
busName <- parseBusName name
when (busName `M.member` playerWidgets) doUpdate
_ <- Gtk.onWidgetRealize grid $ do
updateHandler <-
DBus.registerForPropertiesChanged client propMatcher signalCallback
nameHandler <-
DBus.registerForNameOwnerChanged client matchAny handleNameOwnerChanged
doUpdate
void $ Gtk.onWidgetUnrealize grid $
removeMatch client updateHandler >> removeMatch client nameHandler
Gtk.widgetShow grid
setPlayingClass
return outerWidget
-- | Generate now playing text with the artist truncated to a maximum given by
-- the first provided int, and the song title truncated to a maximum given by
-- the second provided int.
playingText :: MonadIO m => Int -> Int -> NowPlaying -> m T.Text
playingText artistMax songMax NowPlaying {npArtists = artists, npTitle = title} =
G.markupEscapeText formattedText (-1)
where truncatedTitle = truncateString songMax title
formattedText = T.pack $ if null artists
then truncatedTitle
else printf
"%s - %s"
(truncateString artistMax $ intercalate "," artists)
truncatedTitle
taffybar-4.0.1/src/System/Taffybar/Widget/NetworkGraph.hs 0000644 0000000 0000000 00000006407 07346545000 021515 0 ustar 00 0000000 0000000 -----------------------------------------------------------------------------
-- |
-- Module : System.Taffybar.Widget.NetworkGraph
-- Copyright : (c) Ivan A. Malison
-- License : BSD3-style (see LICENSE)
--
-- Maintainer : Ivan A. Malison
-- Stability : unstable
-- Portability : unportable
--
-- This module provides a channel based network graph widget.
-----------------------------------------------------------------------------
module System.Taffybar.Widget.NetworkGraph where
import Data.Default (Default(..))
import Data.Foldable (for_)
import qualified GI.Gtk
import GI.Gtk.Objects.Widget (widgetSetTooltipMarkup)
import System.Taffybar.Context
import System.Taffybar.Hooks
import System.Taffybar.Information.Network
import System.Taffybar.Util (postGUIASync)
import System.Taffybar.Widget.Generic.ChannelGraph
import System.Taffybar.Widget.Generic.ChannelWidget
import System.Taffybar.Widget.Generic.Graph
import System.Taffybar.Widget.Text.NetworkMonitor
-- | 'NetworkGraphConfig' configures the network graph widget.
data NetworkGraphConfig = NetworkGraphConfig
{ networkGraphGraphConfig :: GraphConfig -- ^ The configuration of the graph itself.
-- | A tooltip format string, together with the precision that should be used
-- for numbers in the string.
, networkGraphTooltipFormat :: Maybe (String, Int)
-- | A function to scale the y axis of the network config. The default is
-- `logBase $ 2 ** 32`.
, networkGraphScale :: Double -> Double
-- | A filter function that determines whether a given interface will be
-- included in the network stats.
, interfacesFilter :: String -> Bool
}
-- | Default configuration paramters for the network graph.
defaultNetworkGraphConfig :: NetworkGraphConfig
defaultNetworkGraphConfig = NetworkGraphConfig
{ networkGraphGraphConfig = def
, networkGraphTooltipFormat = Just (defaultNetFormat, 3)
, networkGraphScale = logBase $ 2 ** 32
, interfacesFilter = const True
}
instance Default NetworkGraphConfig where
def = defaultNetworkGraphConfig
-- | 'networkGraphNew' instantiates a network graph widget from a 'GraphConfig'
-- and a list of interfaces.
networkGraphNew :: GraphConfig -> Maybe [String] -> TaffyIO GI.Gtk.Widget
networkGraphNew config interfaces =
networkGraphNewWith def
{ networkGraphGraphConfig = config
, interfacesFilter = maybe (const True) (flip elem) interfaces
}
-- | 'networkGraphNewWith' instantiates a network graph widget from a
-- 'NetworkGraphConfig'.
networkGraphNewWith :: NetworkGraphConfig -> TaffyIO GI.Gtk.Widget
networkGraphNewWith config = do
NetworkInfoChan chan <- getNetworkChan
let getUpDown = sumSpeeds . map snd . filter (interfacesFilter config . fst)
toSample (up, down) = map (networkGraphScale config . fromRational) [up, down]
sampleBuilder = return . toSample . getUpDown
widget <- channelGraphNew (networkGraphGraphConfig config) chan sampleBuilder
for_ (networkGraphTooltipFormat config) $ \(format, precision) ->
channelWidgetNew widget chan $ \speedInfo ->
let (up, down) = sumSpeeds $ map snd speedInfo
tooltip = showInfo format precision (fromRational down, fromRational up)
in postGUIASync $ widgetSetTooltipMarkup widget $ Just tooltip
return widget
taffybar-4.0.1/src/System/Taffybar/Widget/SNITray.hs 0000644 0000000 0000000 00000007005 07346545000 020366 0 ustar 00 0000000 0000000 {-# LANGUAGE OverloadedStrings #-}
-----------------------------------------------------------------------------
-- |
-- Module : System.Taffybar.Widget.SNITray
-- Copyright : (c) Ivan A. Malison
-- License : BSD3-style (see LICENSE)
--
-- Maintainer : Ivan A. Malison
-- Stability : unstable
-- Portability : unportable
--
-- This module exports functions for the construction of
-- StatusNotifierItem/AppIndicator tray widgets, supplied by the
-- "StatusNotifier.Tray" module from the gtk-sni-tray library. These widgets do
-- not support the older XEMBED protocol, although bridges like
-- xembed-sni-proxy do allow sni trays to provide limited support for XEMBED
-- tray icons.
--
-- Unless 'sniTrayThatStartsWatcherEvenThoughThisIsABadWayToDoIt' is used it is
-- necessary to run status-notifier-watcher from the
-- [status-notifier-item](https://github.com/taffybar/status-notifier-item)
-- package before starting taffybar when using the functions defined in this
-- module. Using 'sniTrayThatStartsWatcherEvenThoughThisIsABadWayToDoIt' is
-- generally not recommended, because it can lead to issues with the
-- registration of tray icons if taffybar crashes/restarts, or if tray icon
-- providing applications are ever started before taffybar.
-----------------------------------------------------------------------------
module System.Taffybar.Widget.SNITray
( TrayParams
, module System.Taffybar.Widget.SNITray
) where
import Control.Monad.Trans.Class
import Control.Monad.Trans.Reader
import qualified GI.Gtk
import qualified StatusNotifier.Host.Service as H
import StatusNotifier.Tray
import System.Posix.Process
import System.Taffybar.Context
import System.Taffybar.Widget.Util
import Text.Printf
-- | Build a new StatusNotifierItem tray that will share a host with any other
-- trays that are constructed automatically
sniTrayNew :: TaffyIO GI.Gtk.Widget
sniTrayNew = sniTrayNewFromParams defaultTrayParams
-- | Build a new StatusNotifierItem tray from the provided 'TrayParams'.
sniTrayNewFromParams :: TrayParams -> TaffyIO GI.Gtk.Widget
sniTrayNewFromParams params =
getTrayHost False >>= sniTrayNewFromHostParams params
-- | Build a new StatusNotifierItem tray from the provided 'TrayParams' and
-- 'H.Host'.
sniTrayNewFromHostParams :: TrayParams -> H.Host -> TaffyIO GI.Gtk.Widget
sniTrayNewFromHostParams params host = do
client <- asks sessionDBusClient
lift $ do
tray <- buildTray host client params
_ <- widgetSetClassGI tray "sni-tray"
GI.Gtk.widgetShowAll tray
GI.Gtk.toWidget tray
-- | Build a new StatusNotifierItem tray that also starts its own watcher,
-- without depending on status-notifier-icon. This will not register applets
-- started before the watcher is started.
sniTrayThatStartsWatcherEvenThoughThisIsABadWayToDoIt :: TaffyIO GI.Gtk.Widget
sniTrayThatStartsWatcherEvenThoughThisIsABadWayToDoIt =
getTrayHost True >>= sniTrayNewFromHostParams defaultTrayParams
-- | Get a 'H.Host' from 'TaffyIO' internal state, that can be used to construct
-- SNI tray widgets. The boolean parameter determines whether or not a watcher
-- will be started the first time 'getTrayHost' is invoked.
getTrayHost :: Bool -> TaffyIO H.Host
getTrayHost startWatcher = getStateDefault $ do
pid <- lift getProcessID
client <- asks sessionDBusClient
Just host <- lift $ H.build H.defaultParams
{ H.dbusClient = Just client
, H.uniqueIdentifier = printf "taffybar-%s" $ show pid
, H.startWatcher = startWatcher
}
return host
taffybar-4.0.1/src/System/Taffybar/Widget/SimpleClock.hs 0000644 0000000 0000000 00000013440 07346545000 021302 0 ustar 00 0000000 0000000 {-# LANGUAGE CPP #-}
{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE OverloadedStrings #-}
module System.Taffybar.Widget.SimpleClock
( textClockNew
, textClockNewWith
, defaultClockConfig
, ClockConfig(..)
, ClockUpdateStrategy(..)
) where
import Control.Monad.IO.Class
import Data.Default ( Default(..) )
import Data.Maybe
import qualified Data.Text as T
import Data.Time.Calendar ( toGregorian )
import qualified Data.Time.Clock as Clock
import Data.Time.Format
import Data.Time.LocalTime
import qualified Data.Time.Locale.Compat as L
import qualified GI.Gdk as Gdk
import GI.Gtk
import System.Taffybar.Widget.Generic.PollingLabel
import System.Taffybar.Widget.Util
-- | This module implements a very simple text-based clock widget. The widget
-- also toggles a calendar widget when clicked. This calendar is not fancy at
-- all and has no data backend.
makeCalendar :: IO TimeZone -> IO Window
makeCalendar tzfn = do
container <- windowNew WindowTypeToplevel
cal <- calendarNew
containerAdd container cal
_ <- onWidgetShow container $ resetCalendarDate cal tzfn
-- Hide the calendar instead of destroying it
_ <- onWidgetDeleteEvent container $ \_ -> widgetHide container >> return True
return container
resetCalendarDate :: Calendar -> IO TimeZone -> IO ()
resetCalendarDate cal tzfn = do
tz <- tzfn
current <- Clock.getCurrentTime
let (y,m,d) = toGregorian $ localDay $ utcToLocalTime tz current
calendarSelectMonth cal (fromIntegral m - 1) (fromIntegral y)
calendarSelectDay cal (fromIntegral d)
toggleCalendar :: IsWidget w => w -> Window -> IO Bool
toggleCalendar w c = do
isVis <- widgetGetVisible c
if isVis
then widgetHide c
else do
attachPopup w "Calendar" c
displayPopup w c
return True
-- | Create the widget. I recommend passing @Nothing@ for the TimeLocale
-- parameter. The format string can include Pango markup
-- ().
textClockNew ::
MonadIO m => Maybe L.TimeLocale -> String -> Double -> m GI.Gtk.Widget
textClockNew userLocale format interval =
textClockNewWith cfg
where
cfg = def { clockTimeLocale = userLocale
, clockFormatString = format
, clockUpdateStrategy = ConstantInterval interval
}
data ClockUpdateStrategy
= ConstantInterval Double
| RoundedTargetInterval Int Double
deriving (Eq, Ord, Show)
data ClockConfig = ClockConfig
{ clockTimeZone :: Maybe TimeZone
, clockTimeLocale :: Maybe L.TimeLocale
, clockFormatString :: String
, clockUpdateStrategy :: ClockUpdateStrategy
} deriving (Eq, Ord, Show)
-- | A clock configuration that defaults to the current locale
defaultClockConfig :: ClockConfig
defaultClockConfig = ClockConfig
{ clockTimeZone = Nothing
, clockTimeLocale = Nothing
, clockFormatString = "%a %b %_d %r"
, clockUpdateStrategy = RoundedTargetInterval 5 0.0
}
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'.
--
-- See also 'textClockNew'.
textClockNewWith :: MonadIO m => ClockConfig -> m Widget
textClockNewWith ClockConfig
{ clockTimeZone = userZone
, clockTimeLocale = userLocale
, clockFormatString = formatString
, clockUpdateStrategy = updateStrategy
} = liftIO $ do
let getTZ = maybe systemGetTZ return userZone
locale = fromMaybe L.defaultTimeLocale userLocale
let getUserZonedTime =
utcToZonedTime <$> getTZ <*> Clock.getCurrentTime
doTimeFormat zonedTime = T.pack $ formatTime locale formatString zonedTime
getRoundedTimeAndNextTarget = do
zonedTime <- getUserZonedTime
return $ case updateStrategy of
ConstantInterval interval ->
(doTimeFormat zonedTime, Nothing, interval)
RoundedTargetInterval roundSeconds offset ->
let roundSecondsDiffTime = fromIntegral roundSeconds
addTheRound = addLocalTime roundSecondsDiffTime
localTime = zonedTimeToLocalTime zonedTime
ourLocalTimeOfDay = localTimeOfDay localTime
seconds = round $ todSec ourLocalTimeOfDay
secondsFactor = seconds `div` roundSeconds
displaySeconds = secondsFactor * roundSeconds
baseLocalTimeOfDay =
ourLocalTimeOfDay { todSec = fromIntegral displaySeconds }
ourLocalTime =
localTime { localTimeOfDay = baseLocalTimeOfDay }
roundedLocalTime =
if seconds `mod` roundSeconds > roundSeconds `div` 2
then addTheRound ourLocalTime
else ourLocalTime
roundedZonedTime =
zonedTime { zonedTimeToLocalTime = roundedLocalTime }
nextTarget = addTheRound ourLocalTime
amountToWait = realToFrac $ diffLocalTime nextTarget localTime
in (doTimeFormat roundedZonedTime, Nothing, amountToWait - offset)
label <- pollingLabelWithVariableDelay getRoundedTimeAndNextTarget
ebox <- eventBoxNew
containerAdd ebox label
eventBoxSetVisibleWindow ebox False
cal <- makeCalendar getTZ
_ <- onWidgetButtonPressEvent ebox $ onClick [Gdk.EventTypeButtonPress] $
toggleCalendar label cal
widgetShowAll ebox
toWidget ebox
taffybar-4.0.1/src/System/Taffybar/Widget/SimpleCommandButton.hs 0000644 0000000 0000000 00000002661 07346545000 023024 0 ustar 00 0000000 0000000 {-# LANGUAGE OverloadedStrings #-}
--------------------------------------------------------------------------------
-- |
-- Module : System.Taffybar.Widget.SimpleCommandButton
-- Copyright : (c) Ulf Jasper
-- License : BSD3-style (see LICENSE)
--
-- Maintainer : Ulf Jasper
-- Stability : unstable
-- Portability : unportable
--
-- Simple button which runs a user defined command when being clicked
--------------------------------------------------------------------------------
module System.Taffybar.Widget.SimpleCommandButton (
-- * Usage
-- $usage
simpleCommandButtonNew)
where
import Control.Monad.IO.Class
import GI.Gtk
import System.Process
import qualified Data.Text as T
-- $usage
--
-- In order to use this widget add the following line to your
-- @taffybar.hs@ file:
--
-- > import System.Taffybar.Widget
-- > main = do
-- > let cmdButton = simpleCommandButtonNew "Hello World!" "xterm -e \"echo Hello World!; read x\""
--
-- Now you can use @cmdButton@ like any other Taffybar widget.
-- | Creates a new simple command button.
simpleCommandButtonNew
:: MonadIO m
=> T.Text -- ^ Contents of the button's label.
-> T.Text -- ^ Command to execute. Should be in $PATH or an absolute path
-> m Widget
simpleCommandButtonNew txt cmd = do
button <- buttonNewWithLabel txt
_ <- onButtonClicked button $ spawnCommand (T.unpack cmd) >> return ()
toWidget button
taffybar-4.0.1/src/System/Taffybar/Widget/Text/ 0000755 0000000 0000000 00000000000 07346545000 017463 5 ustar 00 0000000 0000000 taffybar-4.0.1/src/System/Taffybar/Widget/Text/CPUMonitor.hs 0000644 0000000 0000000 00000002361 07346545000 022020 0 ustar 00 0000000 0000000 module System.Taffybar.Widget.Text.CPUMonitor (textCpuMonitorNew) where
import Control.Monad.IO.Class ( MonadIO )
import Text.Printf ( printf )
import qualified Text.StringTemplate as ST
import System.Taffybar.Information.CPU
import System.Taffybar.Widget.Generic.PollingLabel ( pollingLabelNew )
import qualified GI.Gtk
-- | Creates a simple textual CPU monitor. It updates once every polling
-- period (in seconds).
textCpuMonitorNew :: MonadIO m
=> String -- ^ Format. You can use variables: $total$, $user$, $system$
-> Double -- ^ Polling period (in seconds)
-> m GI.Gtk.Widget
textCpuMonitorNew fmt period = do
label <- pollingLabelNew period callback
GI.Gtk.toWidget label
where
callback = do
(userLoad, systemLoad, totalLoad) <- cpuLoad
let [userLoad', systemLoad', totalLoad'] = map (formatPercent.(*100)) [userLoad, systemLoad, totalLoad]
let template = ST.newSTMP fmt
let template' = ST.setManyAttrib [ ("user", userLoad'),
("system", systemLoad'),
("total", totalLoad') ] template
return $ ST.render template'
formatPercent :: Double -> String
formatPercent = printf "%.2f"
taffybar-4.0.1/src/System/Taffybar/Widget/Text/MemoryMonitor.hs 0000644 0000000 0000000 00000004423 07346545000 022642 0 ustar 00 0000000 0000000 module System.Taffybar.Widget.Text.MemoryMonitor (textMemoryMonitorNew, showMemoryInfo) where
import Control.Monad.IO.Class ( MonadIO )
import qualified Data.Text as T
import qualified Text.StringTemplate as ST
import System.Taffybar.Information.Memory
import System.Taffybar.Widget.Generic.PollingLabel ( pollingLabelNew )
import qualified GI.Gtk
import Text.Printf ( printf )
-- | Creates a simple textual memory monitor. It updates once every polling
-- period (in seconds).
textMemoryMonitorNew :: MonadIO m
=> String -- ^ Format. You can use variables: "used", "total", "free", "buffer",
-- "cache", "rest", "available", "swapUsed", "swapTotal", "swapFree".
-> Double -- ^ Polling period in seconds.
-> m GI.Gtk.Widget
textMemoryMonitorNew fmt period = do
label <- pollingLabelNew period (showMemoryInfo fmt 3 <$> parseMeminfo)
GI.Gtk.toWidget label
showMemoryInfo :: String -> Int -> MemoryInfo -> T.Text
showMemoryInfo fmt prec info =
let template = ST.newSTMP fmt
labels = [ "used"
, "total"
, "free"
, "buffer"
, "cache"
, "rest"
, "available"
, "swapUsed"
, "swapTotal"
, "swapFree"
]
actions = [ memoryUsed
, memoryTotal
, memoryFree
, memoryBuffer
, memoryCache
, memoryRest
, memoryAvailable
, memorySwapUsed
, memorySwapTotal
, memorySwapFree
]
actions' = map (toAuto prec .) actions
stats = [f info | f <- actions']
template' = ST.setManyAttrib (zip labels stats) template
in ST.render template'
toAuto :: Int -> Double -> String
toAuto prec value = printf "%.*f%s" p v unit
where value' = max 0 value
mag :: Int
mag = if value' == 0 then 0 else max 0 $ min 2 $ floor $ logBase 1024 value'
v = value' / 1024 ** fromIntegral mag
unit = case mag of
0 -> "MiB"
1 -> "GiB"
2 -> "TiB"
_ -> "??B" -- unreachable
p :: Int
p = max 0 $ floor $ fromIntegral prec - logBase 10 v
taffybar-4.0.1/src/System/Taffybar/Widget/Text/NetworkMonitor.hs 0000644 0000000 0000000 00000004567 07346545000 023034 0 ustar 00 0000000 0000000 module System.Taffybar.Widget.Text.NetworkMonitor where
import Control.Monad
import Control.Monad.Trans.Class
import qualified Data.Text as T
import GI.Gtk
import System.Taffybar.Context
import System.Taffybar.Hooks
import System.Taffybar.Information.Network
import System.Taffybar.Util
import System.Taffybar.Widget.Generic.ChannelWidget
import Text.Printf
import Text.StringTemplate
defaultNetFormat :: String
defaultNetFormat = "▼ $inAuto$ ▲ $outAuto$"
showInfo :: String -> Int -> (Double, Double) -> T.Text
showInfo template prec (incomingb, outgoingb) =
let
attribs = [ ("inB", show incomingb)
, ("inKB", toKB prec incomingb)
, ("inMB", toMB prec incomingb)
, ("inAuto", toAuto prec incomingb)
, ("outB", show outgoingb)
, ("outKB", toKB prec outgoingb)
, ("outMB", toMB prec outgoingb)
, ("outAuto", toAuto prec outgoingb)
]
in
render . setManyAttrib attribs $ newSTMP template
toKB :: Int -> Double -> String
toKB prec = setDigits prec . (/1024)
toMB :: Int -> Double -> String
toMB prec = setDigits prec . (/ (1024 * 1024))
setDigits :: Int -> Double -> String
setDigits dig = printf format
where format = "%." ++ show dig ++ "f"
toAuto :: Int -> Double -> String
toAuto prec value = printf "%.*f%s" p v unit
where value' = max 0 value
mag :: Int
mag = if value' == 0 then 0 else max 0 $ min 4 $ floor $ logBase 1024 value'
v = value' / 1024 ** fromIntegral mag
unit = case mag of
0 -> "B/s"
1 -> "KiB/s"
2 -> "MiB/s"
3 -> "GiB/s"
4 -> "TiB/s"
_ -> "??B/s" -- unreachable
p :: Int
p = max 0 $ floor $ fromIntegral prec - logBase 10 v
networkMonitorNew :: String -> Maybe [String] -> TaffyIO GI.Gtk.Widget
networkMonitorNew template interfaces = do
NetworkInfoChan chan <- getNetworkChan
let filterFn = maybe (const True) (flip elem) interfaces
label <- lift $ labelNew Nothing
void $ channelWidgetNew label chan $ \speedInfo ->
let (up, down) = sumSpeeds $ map snd $ filter (filterFn . fst) speedInfo
labelString = showInfo template 3 (fromRational down, fromRational up)
in postGUIASync $ labelSetMarkup label labelString
toWidget label
taffybar-4.0.1/src/System/Taffybar/Widget/Util.hs 0000644 0000000 0000000 00000020146 07346545000 020013 0 ustar 00 0000000 0000000 {-# LANGUAGE TypeApplications #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE CPP #-}
-----------------------------------------------------------------------------
-- |
-- Module : System.Taffybar.Widget.Util
-- Copyright : (c) Ivan Malison
-- License : BSD3-style (see LICENSE)
--
-- Maintainer : Ivan Malison
-- Stability : unstable
-- Portability : unportable
--
-- Utility functions to facilitate building GTK interfaces.
--
-----------------------------------------------------------------------------
module System.Taffybar.Widget.Util where
import Control.Concurrent ( forkIO )
import Control.Monad
import Control.Monad.IO.Class
import Data.Bifunctor ( first )
import Data.Functor ( ($>) )
import Data.GI.Base.Overloading (IsDescendantOf)
import Data.Int
import qualified Data.Text as T
import qualified GI.Gdk as D
import qualified GI.GdkPixbuf.Objects.Pixbuf as GI
import qualified GI.GdkPixbuf.Objects.Pixbuf as PB
import GI.Gtk as Gtk
import StatusNotifier.Tray (scalePixbufToSize)
import System.Environment.XDG.DesktopEntry
import System.FilePath.Posix
import System.Taffybar.Util
import Text.Printf
import Paths_taffybar ( getDataDir )
-- | Execute the given action as a response to any of the given types
-- of mouse button clicks.
onClick :: [D.EventType] -- ^ Types of button clicks to listen to.
-> IO a -- ^ Action to execute.
-> D.EventButton
-> IO Bool
onClick triggers action btn = do
click <- D.getEventButtonType btn
if click `elem` triggers
then action >> return True
else return False
-- | Attach the given widget as a popup with the given title to the
-- given window. The newly attached popup is not shown initially. Use
-- the 'displayPopup' function to display it.
attachPopup :: (Gtk.IsWidget w, Gtk.IsWindow wnd) =>
w -- ^ The widget to set as popup.
-> T.Text -- ^ The title of the popup.
-> wnd -- ^ The window to attach the popup to.
-> IO ()
attachPopup widget title window = do
windowSetTitle window title
windowSetTypeHint window D.WindowTypeHintTooltip
windowSetSkipTaskbarHint window True
windowSetSkipPagerHint window True
transient <- getWindow
windowSetTransientFor window transient
windowSetKeepAbove window True
windowStick window
where
getWindow :: IO (Maybe Window)
getWindow = do
windowGType <- glibType @Window
Just ancestor <- Gtk.widgetGetAncestor widget windowGType
castTo Window ancestor
-- | Display the given popup widget (previously prepared using the
-- 'attachPopup' function) immediately beneath (or above) the given
-- window.
displayPopup :: (Gtk.IsWidget w, Gtk.IsWidget wnd, Gtk.IsWindow wnd) =>
w -- ^ The popup widget.
-> wnd -- ^ The window the widget was attached to.
-> IO ()
displayPopup widget window = do
windowSetPosition window WindowPositionMouse
(x, y ) <- windowGetPosition window
(_, natReq) <- widgetGetPreferredSize =<< widgetGetToplevel widget
y' <- getRequisitionHeight natReq
widgetShowAll window
if y > y'
then windowMove window x (y - y')
else windowMove window x y'
widgetGetAllocatedSize
:: (Gtk.IsWidget self, MonadIO m)
=> self -> m (Int, Int)
widgetGetAllocatedSize widget = do
w <- Gtk.widgetGetAllocatedWidth widget
h <- Gtk.widgetGetAllocatedHeight widget
return (fromIntegral w, fromIntegral h)
-- | Creates markup with the given foreground and background colors and the
-- given contents.
colorize :: String -- ^ Foreground color.
-> String -- ^ Background color.
-> String -- ^ Contents.
-> String
colorize fg bg = printf "%s" (attr ("fg" :: String) fg :: String) (attr ("bg" :: String) bg :: String)
where attr name value
| null value = ""
| otherwise = printf " %scolor=\"%s\"" name value
backgroundLoop :: IO a -> IO ()
backgroundLoop = void . forkIO . forever
drawOn :: Gtk.IsWidget object => object -> IO () -> IO object
drawOn drawArea action = Gtk.onWidgetRealize drawArea action $> drawArea
widgetSetClassGI :: (Gtk.IsWidget b, MonadIO m) => b -> T.Text -> m b
widgetSetClassGI widget klass =
Gtk.widgetGetStyleContext widget >>=
flip Gtk.styleContextAddClass klass >> return widget
themeLoadFlags :: [Gtk.IconLookupFlags]
themeLoadFlags =
[ Gtk.IconLookupFlagsGenericFallback
, Gtk.IconLookupFlagsUseBuiltin
]
getImageForDesktopEntry :: Int32 -> DesktopEntry -> IO (Maybe GI.Pixbuf)
getImageForDesktopEntry size de = getImageForMaybeIconName (T.pack <$> deIcon de) size
getImageForMaybeIconName :: Maybe T.Text -> Int32 -> IO (Maybe GI.Pixbuf)
getImageForMaybeIconName mIconName size =
join <$> sequenceA (flip getImageForIconName size <$> mIconName)
getImageForIconName :: T.Text -> Int32 -> IO (Maybe GI.Pixbuf)
getImageForIconName iconName size =
maybeTCombine (loadPixbufByName size iconName)
(getPixbufFromFilePath (T.unpack iconName) >>=
traverse (scalePixbufToSize size Gtk.OrientationHorizontal))
loadPixbufByName :: Int32 -> T.Text -> IO (Maybe GI.Pixbuf)
loadPixbufByName size name = do
iconTheme <- Gtk.iconThemeGetDefault
hasIcon <- Gtk.iconThemeHasIcon iconTheme name
if hasIcon
then Gtk.iconThemeLoadIcon iconTheme name size themeLoadFlags
else return Nothing
alignCenter :: (Gtk.IsWidget o, MonadIO m) => o -> m ()
alignCenter widget =
Gtk.setWidgetValign widget Gtk.AlignCenter >>
Gtk.setWidgetHalign widget Gtk.AlignCenter
vFillCenter :: (Gtk.IsWidget o, MonadIO m) => o -> m ()
vFillCenter widget =
Gtk.widgetSetVexpand widget True >>
Gtk.setWidgetValign widget Gtk.AlignFill >>
Gtk.setWidgetHalign widget Gtk.AlignCenter
pixbufNewFromFileAtScaleByHeight :: Int32 -> String -> IO (Either String PB.Pixbuf)
pixbufNewFromFileAtScaleByHeight height name =
fmap (handleResult . first show) $ catchGErrorsAsLeft $
PB.pixbufNewFromFileAtScale name (-1) height True
where
handleResult = (maybe (Left "gdk function returned NULL") Right =<<)
loadIcon :: Int32 -> String -> IO (Either String PB.Pixbuf)
loadIcon height name =
getDataDir >>=
pixbufNewFromFileAtScaleByHeight height . ( "icons" name)
setMinWidth :: (Gtk.IsWidget w, MonadIO m) => Int -> w -> m w
setMinWidth width widget = liftIO $ do
Gtk.widgetSetSizeRequest widget (fromIntegral width) (-1)
return widget
addClassIfMissing ::
(IsDescendantOf Widget a, MonadIO m, GObject a) => T.Text -> a -> m ()
addClassIfMissing klass widget = do
context <- Gtk.widgetGetStyleContext widget
Gtk.styleContextHasClass context klass >>=
(`when` Gtk.styleContextAddClass context klass) . not
removeClassIfPresent ::
(IsDescendantOf Widget a, MonadIO m, GObject a) => T.Text -> a -> m ()
removeClassIfPresent klass widget = do
context <- Gtk.widgetGetStyleContext widget
Gtk.styleContextHasClass context klass >>=
(`when` Gtk.styleContextRemoveClass context klass)
-- | Wrap a widget with two container boxes. The inner box will have the class
-- "inner-pad", and the outer box will have the class "outer-pad". These boxes
-- can be used to add padding between the outline of the widget and its
-- contents, or for the purpose of displaying a different background behind the
-- widget.
buildPadBox :: MonadIO m => Gtk.Widget -> m Gtk.Widget
buildPadBox contents = liftIO $ do
innerBox <- Gtk.boxNew Gtk.OrientationHorizontal 0
outerBox <- Gtk.boxNew Gtk.OrientationHorizontal 0
Gtk.setWidgetValign innerBox Gtk.AlignFill
Gtk.setWidgetValign outerBox Gtk.AlignFill
Gtk.containerAdd innerBox contents
Gtk.containerAdd outerBox innerBox
_ <- widgetSetClassGI innerBox "inner-pad"
_ <- widgetSetClassGI outerBox "outer-pad"
Gtk.widgetShow outerBox
Gtk.widgetShow innerBox
Gtk.toWidget outerBox
buildContentsBox :: MonadIO m => Gtk.Widget -> m Gtk.Widget
buildContentsBox widget = liftIO $ do
contents <- Gtk.boxNew Gtk.OrientationHorizontal 0
Gtk.containerAdd contents widget
_ <- widgetSetClassGI contents "contents"
Gtk.widgetShowAll contents
Gtk.toWidget contents >>= buildPadBox
taffybar-4.0.1/src/System/Taffybar/Widget/Weather.hs 0000644 0000000 0000000 00000026315 07346545000 020501 0 ustar 00 0000000 0000000 {-# LANGUAGE OverloadedStrings #-}
-- | This module defines a simple textual weather widget that polls
-- NOAA for weather data. To find your weather station, you can use
-- either of the following:
--
--
--
--
-- For example, Madison, WI is KMSN.
--
-- NOAA provides several pieces of information in each request; you can control
-- which pieces end up in your weather widget by providing a _template_ that is
-- filled in with the current information. The template is just a 'String' with
-- variables between dollar signs. The variables will be substituted with real
-- data by the widget. Example:
--
-- > let wcfg = (defaultWeatherConfig "KMSN") { weatherTemplate = "$tempC$ C @ $humidity$" }
-- > weatherWidget = weatherNew wcfg 10
--
-- This example makes a new weather widget that checks the weather at KMSN
-- (Madison, WI) every 10 minutes, and displays the results in Celcius.
--
-- Available variables:
--
-- [@stationPlace@] The name of the weather station
--
-- [@stationState@] The state that the weather station is in
--
-- [@year@] The year the report was generated
--
-- [@month@] The month the report was generated
--
-- [@day@] The day the report was generated
--
-- [@hour@] The hour the report was generated
--
-- [@wind@] The direction and strength of the wind
--
-- [@visibility@] Description of current visibility conditions
--
-- [@skyCondition@] ?
--
-- [@tempC@] The temperature in Celsius
--
-- [@tempF@] The temperature in Farenheit
--
-- [@dewPoint@] The current dew point
--
-- [@humidity@] The current relative humidity
--
-- [@pressure@] The current pressure
--
--
-- As an example, a template like
--
-- > "$tempF$ °F"
--
-- would yield a widget displaying the temperature in Farenheit with a small
-- label after it.
--
-- Implementation Note: the weather data parsing code is taken from xmobar. This
-- version of the code makes direct HTTP requests instead of invoking a separate
-- cURL process.
module System.Taffybar.Widget.Weather
( WeatherConfig(..)
, WeatherInfo(..)
, WeatherFormatter(WeatherFormatter)
, weatherNew
, weatherCustomNew
, defaultWeatherConfig
) where
import Control.Monad.IO.Class
import qualified Data.ByteString.Lazy as LB
import Data.List (stripPrefix)
import Data.Maybe (fromMaybe)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import GI.GLib(markupEscapeText)
import GI.Gtk
import Network.HTTP.Client
import Network.HTTP.Client.TLS (tlsManagerSettings)
import Network.HTTP.Types.Status
import System.Log.Logger
import Text.Parsec
import Text.Printf
import Text.StringTemplate
import System.Taffybar.Widget.Generic.PollingLabel
data WeatherInfo = WI
{ stationPlace :: String
, stationState :: String
, year :: String
, month :: String
, day :: String
, hour :: String
, wind :: String
, visibility :: String
, skyCondition :: String
, tempC :: Int
, tempF :: Int
, dewPoint :: String
, humidity :: Int
, pressure :: Int
} deriving (Show)
-- Parsers stolen from xmobar
type Parser = Parsec String ()
pTime :: Parser (String, String, String, String)
pTime = do
y <- getNumbersAsString
_ <- char '.'
m <- getNumbersAsString
_ <- char '.'
d <- getNumbersAsString
_ <- char ' '
(h:hh:mi:mimi) <- getNumbersAsString
_ <- char ' '
return (y, m, d , [h]++[hh]++":"++[mi]++mimi)
pTemp :: Parser (Int, Int)
pTemp = do
let num = digit <|> char '-' <|> char '.'
f <- manyTill num $ char ' '
_ <- manyTill anyChar $ char '('
c <- manyTill num $ char ' '
_ <- skipRestOfLine
return (floor (read c :: Double), floor (read f :: Double))
pRh :: Parser Int
pRh = do
s <- manyTill digit $ char '%' <|> char '.'
return $ read s
pPressure :: Parser Int
pPressure = do
_ <- manyTill anyChar $ char '('
s <- manyTill digit $ char ' '
_ <- skipRestOfLine
return $ read s
parseData :: Parser WeatherInfo
parseData = do
st <- getAllBut ","
_ <- space
ss <- getAllBut "("
_ <- skipRestOfLine >> getAllBut "/"
(y,m,d,h) <- pTime
w <- getAfterString "Wind: "
v <- getAfterString "Visibility: "
sk <- getAfterString "Sky conditions: "
_ <- skipTillString "Temperature: "
(tC,tF) <- pTemp
dp <- getAfterString "Dew Point: "
_ <- skipTillString "Relative Humidity: "
rh <- pRh
_ <- skipTillString "Pressure (altimeter): "
p <- pPressure
_ <- manyTill skipRestOfLine eof
return $ WI st ss y m d h w v sk tC tF dp rh p
getAllBut :: String -> Parser String
getAllBut s =
manyTill (noneOf s) (char $ head s)
getAfterString :: String -> Parser String
getAfterString s = pAfter <|> return ("<" ++ s ++ " not found!>")
where
pAfter = do
_ <- try $ manyTill skipRestOfLine $ string s
manyTill anyChar newline
skipTillString :: String -> Parser String
skipTillString s =
manyTill skipRestOfLine $ string s
getNumbersAsString :: Parser String
getNumbersAsString = skipMany space >> many1 digit >>= \n -> return n
skipRestOfLine :: Parser Char
skipRestOfLine = do
_ <- many $ noneOf "\n\r"
newline
-- | Simple: download the document at a URL.
downloadURL :: Manager -> Request -> IO (Either String String)
downloadURL mgr request = do
response <- httpLbs request mgr
case responseStatus response of
s | s >= status200 && s < status300 ->
return $ Right (T.unpack . T.decodeUtf8 . LB.toStrict $ responseBody response)
otherStatus ->
return . Left $ "HTTP 2XX status was expected but received " ++ show otherStatus
getWeather :: Manager -> String -> IO (Either String WeatherInfo)
getWeather mgr url = do
request <- parseRequest url
dat <- downloadURL mgr request
case dat of
Right dat' -> case parse parseData url dat' of
Right d -> return (Right d)
Left err -> return (Left (show err))
Left err -> return (Left (show err))
defaultFormatter :: StringTemplate String -> WeatherInfo -> String
defaultFormatter tpl wi = render tpl'
where
tpl' = setManyAttrib [ ("stationPlace", stationPlace wi)
, ("stationState", stationState wi)
, ("year", year wi)
, ("month", month wi)
, ("day", day wi)
, ("hour", hour wi)
, ("wind", wind wi)
, ("visibility", visibility wi)
, ("skyCondition", skyCondition wi)
, ("tempC", show (tempC wi))
, ("tempF", show (tempF wi))
, ("dewPoint", dewPoint wi)
, ("humidity", show (humidity wi))
, ("pressure", show (pressure wi))
] tpl
getCurrentWeather :: IO (Either String WeatherInfo)
-> StringTemplate String
-> StringTemplate String
-> WeatherFormatter
-> IO (T.Text, Maybe T.Text)
getCurrentWeather getter labelTpl tooltipTpl formatter = do
dat <- getter
case dat of
Right wi ->
case formatter of
DefaultWeatherFormatter -> do
let rawLabel = T.pack $ defaultFormatter labelTpl wi
let rawTooltip = T.pack $ defaultFormatter tooltipTpl wi
lbl <- markupEscapeText rawLabel (-1)
tooltip <- markupEscapeText rawTooltip (-1)
return (lbl, Just tooltip)
WeatherFormatter f -> do
let rawLabel = T.pack $ f wi
lbl <- markupEscapeText rawLabel (-1)
return (lbl, Just lbl)
Left err -> do
logM "System.Taffybar.Widget.Weather" ERROR $ "Error in weather: " <> show err
return ("N/A", Nothing)
-- | The NOAA URL to get data from
baseUrl :: String
baseUrl = "https://tgftp.nws.noaa.gov/data/observations/metar/decoded"
-- | A wrapper to allow users to specify a custom weather formatter.
-- The default interpolates variables into a string as described
-- above. Custom formatters can do basically anything.
data WeatherFormatter
= WeatherFormatter (WeatherInfo -> String) -- ^ Specify a custom formatter for 'WeatherInfo'
| DefaultWeatherFormatter -- ^ Use the default StringTemplate formatter
-- | The configuration for the weather widget. You can provide a custom
-- format string through 'weatherTemplate' as described above, or you can
-- provide a custom function to turn a 'WeatherInfo' into a String via the
-- 'weatherFormatter' field.
data WeatherConfig = WeatherConfig
{ weatherStation :: String -- ^ The weather station to poll. No default
, weatherTemplate :: String -- ^ Template string, as described above. Default: $tempF$ °F
, weatherTemplateTooltip :: String -- ^ Template string, as described above. Default: $tempF$ °F
, weatherFormatter :: WeatherFormatter -- ^ Default: substitute in all interpolated variables (above)
, weatherProxy :: Maybe String -- ^ The proxy server, e.g. "http://proxy:port". Default: Nothing
}
-- | A sensible default configuration for the weather widget that just
-- renders the temperature.
defaultWeatherConfig :: String -> WeatherConfig
defaultWeatherConfig station =
WeatherConfig
{ weatherStation = station
, weatherTemplate = "$tempF$ °F"
, weatherTemplateTooltip =
unlines
[ "Station: $stationPlace$"
, "Time: $day$.$month$.$year$ $hour$"
, "Temperature: $tempF$ °F"
, "Pressure: $pressure$ hPa"
, "Wind: $wind$"
, "Visibility: $visibility$"
, "Sky Condition: $skyCondition$"
, "Dew Point: $dewPoint$"
, "Humidity: $humidity$"
]
, weatherFormatter = DefaultWeatherFormatter
, weatherProxy = Nothing
}
-- | Create a periodically-updating weather widget that polls NOAA.
weatherNew :: MonadIO m
=> WeatherConfig -- ^ Configuration to render
-> Double -- ^ Polling period in _minutes_
-> m GI.Gtk.Widget
weatherNew cfg delayMinutes = liftIO $ do
-- TODO: add explicit proxy host/port to WeatherConfig and
-- get rid of this ugly stringly-typed setting
let usedProxy = case weatherProxy cfg of
Nothing -> noProxy
Just str ->
let strToBs = T.encodeUtf8 . T.pack
noHttp = fromMaybe str $ stripPrefix "http://" str
(phost, pport) = case span (':'/=) noHttp of
(h, "") -> (strToBs h, 80) -- HTTP seems to assume 80 to be the default
(h, ':':p) -> (strToBs h, read p)
_ -> error "unreachable: broken span"
in useProxy $ Proxy phost pport
mgr <- newManager $ managerSetProxy usedProxy tlsManagerSettings
let url = printf "%s/%s.TXT" baseUrl (weatherStation cfg)
let getter = getWeather mgr url
weatherCustomNew getter (weatherTemplate cfg) (weatherTemplateTooltip cfg)
(weatherFormatter cfg) delayMinutes
-- | Create a periodically-updating weather widget using custom weather getter
weatherCustomNew
:: MonadIO m
=> IO (Either String WeatherInfo) -- ^ Weather querying action
-> String -- ^ Weather template
-> String -- ^ Weather template
-> WeatherFormatter -- ^ Weather formatter
-> Double -- ^ Polling period in _minutes_
-> m GI.Gtk.Widget
weatherCustomNew getter labelTpl tooltipTpl formatter delayMinutes = liftIO $ do
let labelTpl' = newSTMP labelTpl
tooltipTpl' = newSTMP tooltipTpl
l <- pollingLabelNewWithTooltip (delayMinutes * 60)
(getCurrentWeather getter labelTpl' tooltipTpl' formatter)
GI.Gtk.widgetShowAll l
return l
taffybar-4.0.1/src/System/Taffybar/Widget/Windows.hs 0000644 0000000 0000000 00000007620 07346545000 020532 0 ustar 00 0000000 0000000 {-# LANGUAGE OverloadedStrings #-}
-----------------------------------------------------------------------------
-- |
-- Module : System.Taffybar.Widget.Windows
-- Copyright : (c) Ivan Malison
-- License : BSD3-style (see LICENSE)
--
-- Maintainer : Ivan Malison
-- Stability : unstable
-- Portability : unportable
--
-- Menu widget that shows the title of the currently focused window and that,
-- when clicked, displays a menu from which the user may select a window to
-- which to switch the focus.
-----------------------------------------------------------------------------
module System.Taffybar.Widget.Windows where
import Control.Monad
import Control.Monad.Trans.Class
import Control.Monad.Trans.Reader
import Data.Default (Default(..))
import Data.Maybe
import qualified Data.Text as T
import GI.GLib (markupEscapeText)
import qualified GI.Gtk as Gtk
import System.Taffybar.Context
import System.Taffybar.Information.EWMHDesktopInfo
import System.Taffybar.Util
import System.Taffybar.Widget.Generic.DynamicMenu
import System.Taffybar.Widget.Util
data WindowsConfig = WindowsConfig
{ getMenuLabel :: X11Window -> TaffyIO T.Text
-- ^ A monadic function that will be used to make a label for the window in
-- the window menu.
, getActiveLabel :: TaffyIO T.Text
-- ^ Action to build the label text for the active window.
}
defaultGetMenuLabel :: X11Window -> TaffyIO T.Text
defaultGetMenuLabel window = do
windowString <- runX11Def "(nameless window)" (getWindowTitle window)
return $ T.pack windowString
defaultGetActiveLabel :: TaffyIO T.Text
defaultGetActiveLabel = do
label <- fromMaybe "" <$> (runX11Def Nothing getActiveWindow >>=
traverse defaultGetMenuLabel)
markupEscapeText label (-1)
truncatedGetActiveLabel :: Int -> TaffyIO T.Text
truncatedGetActiveLabel maxLength =
truncateText maxLength <$> defaultGetActiveLabel
truncatedGetMenuLabel :: Int -> X11Window -> TaffyIO T.Text
truncatedGetMenuLabel maxLength =
fmap (truncateText maxLength) . defaultGetMenuLabel
defaultWindowsConfig :: WindowsConfig
defaultWindowsConfig =
WindowsConfig
{ getMenuLabel = truncatedGetMenuLabel 35
, getActiveLabel = truncatedGetActiveLabel 35
}
instance Default WindowsConfig where
def = defaultWindowsConfig
-- | Create a new Windows widget that will use the given Pager as
-- its source of events.
windowsNew :: WindowsConfig -> TaffyIO Gtk.Widget
windowsNew config = do
label <- lift $ Gtk.labelNew Nothing
let setLabelTitle title = lift $ postGUIASync $ Gtk.labelSetMarkup label title
activeWindowUpdatedCallback _ = getActiveLabel config >>= setLabelTitle
subscription <-
subscribeToPropertyEvents [ewmhActiveWindow, ewmhWMName, ewmhWMClass]
activeWindowUpdatedCallback
_ <- liftReader (\x -> Gtk.onWidgetUnrealize label x) (unsubscribe subscription)
context <- ask
labelWidget <- Gtk.toWidget label
menu <- dynamicMenuNew
DynamicMenuConfig { dmClickWidget = labelWidget
, dmPopulateMenu = flip runReaderT context . fillMenu config
}
widgetSetClassGI menu "windows"
-- | Populate the given menu widget with the list of all currently open windows.
fillMenu :: Gtk.IsMenuShell a => WindowsConfig -> a -> ReaderT Context IO ()
fillMenu config menu = ask >>= \context ->
runX11Def () $ do
windowIds <- getWindows
forM_ windowIds $ \windowId ->
lift $ do
labelText <- runReaderT (getMenuLabel config windowId) context
let focusCallback = runReaderT (runX11 $ focusWindow windowId) context >>
return True
item <- Gtk.menuItemNewWithLabel labelText
_ <- Gtk.onWidgetButtonPressEvent item $ const focusCallback
Gtk.menuShellAppend menu item
Gtk.widgetShow item
taffybar-4.0.1/src/System/Taffybar/Widget/Workspaces.hs 0000644 0000000 0000000 00000100025 07346545000 021212 0 ustar 00 0000000 0000000 {-# OPTIONS_GHC -fno-warn-type-defaults #-}
{-# LANGUAGE ScopedTypeVariables, ExistentialQuantification, RankNTypes, OverloadedStrings #-}
-----------------------------------------------------------------------------
-- |
-- Module : System.Taffybar.Widget.Workspaces
-- Copyright : (c) Ivan A. Malison
-- License : BSD3-style (see LICENSE)
--
-- Maintainer : Ivan A. Malison
-- Stability : unstable
-- Portability : unportable
-----------------------------------------------------------------------------
module System.Taffybar.Widget.Workspaces where
import Control.Applicative
import Control.Arrow ((&&&))
import Control.Concurrent
import qualified Control.Concurrent.MVar as MV
import Control.Exception.Enclosed (catchAny)
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.Class
import Control.Monad.Trans.Maybe
import Control.Monad.Trans.Reader
import Control.RateLimit
import Data.Default (Default(..))
import qualified Data.Foldable as F
import Data.GI.Base.ManagedPtr (unsafeCastTo)
import Data.Int
import Data.List (elemIndex, intersect, sortBy, (\\))
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
import Data.Tuple.Select
import Data.Tuple.Sequence
import qualified GI.Gdk.Enums as Gdk
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
import System.Taffybar.Information.EWMHDesktopInfo
import System.Taffybar.Information.SafeX11
import System.Taffybar.Information.X11DesktopInfo
import System.Taffybar.Util
import System.Taffybar.Widget.Generic.AutoSizeImage (autoSizeImage)
import System.Taffybar.Widget.Util
import System.Taffybar.WindowIcon
import Text.Printf
data WorkspaceState
= Active
| Visible
| Hidden
| Empty
| Urgent
deriving (Show, Eq)
getCSSClass :: (Show s) => s -> T.Text
getCSSClass = T.toLower . T.pack . show
cssWorkspaceStates :: [T.Text]
cssWorkspaceStates = map getCSSClass [Active, Visible, Hidden, Empty, Urgent]
data WindowData = WindowData
{ windowId :: X11Window
, windowTitle :: String
, windowClass :: String
, windowUrgent :: Bool
, windowActive :: Bool
, windowMinimized :: Bool
} deriving (Show, Eq)
data WidgetUpdate = WorkspaceUpdate Workspace | IconUpdate [X11Window]
data Workspace = Workspace
{ workspaceIdx :: WorkspaceId
, workspaceName :: String
, workspaceState :: WorkspaceState
, windows :: [WindowData]
} deriving (Show, Eq)
data WorkspacesContext = WorkspacesContext
{ controllersVar :: MV.MVar (M.Map WorkspaceId WWC)
, workspacesVar :: MV.MVar (M.Map WorkspaceId Workspace)
, workspacesWidget :: Gtk.Box
, workspacesConfig :: WorkspacesConfig
, taffyContext :: Context
}
type WorkspacesIO a = ReaderT WorkspacesContext IO a
liftContext :: TaffyIO a -> WorkspacesIO a
liftContext action = asks taffyContext >>= lift . runReaderT action
liftX11Def :: a -> X11Property a -> WorkspacesIO a
liftX11Def dflt prop = liftContext $ runX11Def dflt prop
setWorkspaceWidgetStatusClass ::
(MonadIO m, Gtk.IsWidget a) => Workspace -> a -> m ()
setWorkspaceWidgetStatusClass workspace widget =
updateWidgetClasses
widget
[getCSSClass $ workspaceState workspace]
cssWorkspaceStates
updateWidgetClasses ::
(Foldable t1, Foldable t, Gtk.IsWidget a, MonadIO m)
=> a
-> t1 T.Text
-> t T.Text
-> m ()
updateWidgetClasses widget toAdd toRemove = do
context <- Gtk.widgetGetStyleContext widget
let hasClass = Gtk.styleContextHasClass context
addIfMissing klass =
hasClass klass >>= (`when` Gtk.styleContextAddClass context klass) . not
removeIfPresent klass = unless (klass `elem` toAdd) $
hasClass klass >>= (`when` Gtk.styleContextRemoveClass context klass)
mapM_ removeIfPresent toRemove
mapM_ addIfMissing toAdd
class WorkspaceWidgetController wc where
getWidget :: wc -> WorkspacesIO Gtk.Widget
updateWidget :: wc -> WidgetUpdate -> WorkspacesIO wc
updateWidgetX11 :: wc -> WidgetUpdate -> WorkspacesIO wc
updateWidgetX11 cont _ = return cont
data WWC = forall a. WorkspaceWidgetController a => WWC a
instance WorkspaceWidgetController WWC where
getWidget (WWC wc) = getWidget wc
updateWidget (WWC wc) update = WWC <$> updateWidget wc update
updateWidgetX11 (WWC wc) update = WWC <$> updateWidgetX11 wc update
type ControllerConstructor = Workspace -> WorkspacesIO WWC
type ParentControllerConstructor =
ControllerConstructor -> ControllerConstructor
type WindowIconPixbufGetter =
Int32 -> WindowData -> TaffyIO (Maybe Gdk.Pixbuf)
data WorkspacesConfig =
WorkspacesConfig
{ widgetBuilder :: ControllerConstructor
, widgetGap :: Int
, maxIcons :: Maybe Int
, minIcons :: Int
, getWindowIconPixbuf :: WindowIconPixbufGetter
, labelSetter :: Workspace -> WorkspacesIO String
, showWorkspaceFn :: Workspace -> Bool
, borderWidth :: Int
, updateEvents :: [String]
, updateRateLimitMicroseconds :: Integer
, iconSort :: [WindowData] -> WorkspacesIO [WindowData]
, urgentWorkspaceState :: Bool
}
defaultWorkspacesConfig :: WorkspacesConfig
defaultWorkspacesConfig =
WorkspacesConfig
{ widgetBuilder = buildButtonController defaultBuildContentsController
, widgetGap = 0
, maxIcons = Nothing
, minIcons = 0
, getWindowIconPixbuf = defaultGetWindowIconPixbuf
, labelSetter = return . workspaceName
, showWorkspaceFn = const True
, borderWidth = 2
, iconSort = sortWindowsByPosition
, updateEvents = allEWMHProperties \\ [ewmhWMIcon]
, updateRateLimitMicroseconds = 100000
, urgentWorkspaceState = False
}
instance Default WorkspacesConfig where
def = defaultWorkspacesConfig
hideEmpty :: Workspace -> Bool
hideEmpty Workspace { workspaceState = Empty } = False
hideEmpty _ = True
wLog :: MonadIO m => Priority -> String -> m ()
wLog l s = liftIO $ logM "System.Taffybar.Widget.Workspaces" l s
updateVar :: MV.MVar a -> (a -> WorkspacesIO a) -> WorkspacesIO a
updateVar var modify = do
ctx <- ask
lift $ MV.modifyMVar var $ fmap (\a -> (a, a)) . flip runReaderT ctx . modify
updateWorkspacesVar :: WorkspacesIO (M.Map WorkspaceId Workspace)
updateWorkspacesVar = do
workspacesRef <- asks workspacesVar
updateVar workspacesRef buildWorkspaceData
getWorkspaceToWindows ::
[X11Window] -> X11Property (MM.MultiMap WorkspaceId X11Window)
getWorkspaceToWindows =
foldM
(\theMap window ->
MM.insert <$> getWorkspace window <*> pure window <*> pure theMap)
MM.empty
getWindowData :: Maybe X11Window
-> [X11Window]
-> X11Window
-> X11Property WindowData
getWindowData activeWindow urgentWindows window = do
wTitle <- getWindowTitle window
wClass <- getWindowClass window
wMinimized <- getWindowMinimized window
return
WindowData
{ windowId = window
, windowTitle = wTitle
, windowClass = wClass
, windowUrgent = window `elem` urgentWindows
, windowActive = Just window == activeWindow
, windowMinimized = wMinimized
}
buildWorkspaceData :: M.Map WorkspaceId Workspace
-> WorkspacesIO (M.Map WorkspaceId Workspace)
buildWorkspaceData _ = ask >>= \context -> liftX11Def M.empty $ do
names <- getWorkspaceNames
wins <- getWindows
workspaceToWindows <- getWorkspaceToWindows wins
urgentWindows <- filterM isWindowUrgent wins
activeWindow <- getActiveWindow
active:visible <- getVisibleWorkspaces
let getWorkspaceState idx ws
| idx == active = Active
| idx `elem` visible = Visible
| urgentWorkspaceState (workspacesConfig context) &&
not (null (ws `intersect` urgentWindows)) =
Urgent
| null ws = Empty
| otherwise = Hidden
foldM
(\theMap (idx, name) -> do
let ws = MM.lookup idx workspaceToWindows
windowInfos <- mapM (getWindowData activeWindow urgentWindows) ws
return $
M.insert
idx
Workspace
{ workspaceIdx = idx
, workspaceName = name
, workspaceState = getWorkspaceState idx ws
, windows = windowInfos
}
theMap)
M.empty
names
addWidgetsToTopLevel :: WorkspacesIO ()
addWidgetsToTopLevel = do
WorkspacesContext
{ controllersVar = controllersRef
, workspacesWidget = cont
} <- ask
controllersMap <- lift $ MV.readMVar controllersRef
-- Elems returns elements in ascending order of their keys so this will always
-- add the widgets in the correct order
mapM_ addWidget $ M.elems controllersMap
lift $ Gtk.widgetShowAll cont
addWidget :: WWC -> WorkspacesIO ()
addWidget controller = do
cont <- asks workspacesWidget
workspaceWidget <- getWidget controller
lift $ do
-- XXX: This hbox exists to (hopefully) prevent the issue where workspace
-- widgets appear out of order, in the switcher, by acting as an empty
-- place holder when the actual widget is hidden.
hbox <- Gtk.boxNew Gtk.OrientationHorizontal 0
void $ Gtk.widgetGetParent workspaceWidget >>=
traverse (unsafeCastTo Gtk.Box) >>=
traverse (flip Gtk.containerRemove workspaceWidget)
Gtk.containerAdd hbox workspaceWidget
Gtk.containerAdd cont hbox
workspacesNew :: WorkspacesConfig -> TaffyIO Gtk.Widget
workspacesNew cfg = ask >>= \tContext -> lift $ do
cont <- Gtk.boxNew Gtk.OrientationHorizontal $ fromIntegral (widgetGap cfg)
controllersRef <- MV.newMVar M.empty
workspacesRef <- MV.newMVar M.empty
let context =
WorkspacesContext
{ controllersVar = controllersRef
, workspacesVar = workspacesRef
, workspacesWidget = cont
, workspacesConfig = cfg
, taffyContext = tContext
}
-- This will actually create all the widgets
runReaderT updateAllWorkspaceWidgets context
updateHandler <- onWorkspaceUpdate context
iconHandler <- onIconsChanged context
let doUpdate = lift . updateHandler
handleConfigureEvents e@(ConfigureEvent {}) = doUpdate e
handleConfigureEvents _ = return ()
(workspaceSubscription, iconSubscription, geometrySubscription) <-
flip runReaderT tContext $ sequenceT
( subscribeToPropertyEvents (updateEvents cfg) $ doUpdate
, subscribeToPropertyEvents [ewmhWMIcon] (lift . onIconChanged iconHandler)
, subscribeToAll handleConfigureEvents
)
let doUnsubscribe = flip runReaderT tContext $
mapM_ unsubscribe
[ iconSubscription
, workspaceSubscription
, geometrySubscription
]
_ <- Gtk.onWidgetUnrealize cont doUnsubscribe
_ <- widgetSetClassGI cont "workspaces"
Gtk.toWidget cont
updateAllWorkspaceWidgets :: WorkspacesIO ()
updateAllWorkspaceWidgets = do
wLog DEBUG "Updating workspace widgets"
workspacesMap <- updateWorkspacesVar
wLog DEBUG $ printf "Workspaces: %s" $ show workspacesMap
wLog DEBUG "Adding and removing widgets"
updateWorkspaceControllers
let updateController' idx controller =
maybe (return controller)
(updateWidget controller . WorkspaceUpdate) $
M.lookup idx workspacesMap
logUpdateController i =
wLog DEBUG $ printf "Updating %s workspace widget" $ show i
updateController i cont = logUpdateController i >>
updateController' i cont
wLog DEBUG "Done updating individual widget"
doWidgetUpdate updateController
wLog DEBUG "Showing and hiding controllers"
setControllerWidgetVisibility
setControllerWidgetVisibility :: WorkspacesIO ()
setControllerWidgetVisibility = do
ctx@WorkspacesContext
{ workspacesVar = workspacesRef
, controllersVar = controllersRef
, workspacesConfig = cfg
} <- ask
lift $ do
workspacesMap <- MV.readMVar workspacesRef
controllersMap <- MV.readMVar controllersRef
forM_ (M.elems workspacesMap) $ \ws ->
let action = if showWorkspaceFn cfg ws
then Gtk.widgetShow
else Gtk.widgetHide
in
traverse (flip runReaderT ctx . getWidget)
(M.lookup (workspaceIdx ws) controllersMap) >>=
maybe (return ()) action
doWidgetUpdate :: (WorkspaceId -> WWC -> WorkspacesIO WWC) -> WorkspacesIO ()
doWidgetUpdate updateController = do
c@WorkspacesContext { controllersVar = controllersRef } <- ask
lift $ MV.modifyMVar_ controllersRef $ \controllers -> do
wLog DEBUG "Updating controllers ref"
controllersList <-
mapM
(\(idx, controller) -> do
newController <- runReaderT (updateController idx controller) c
return (idx, newController)) $
M.toList controllers
return $ M.fromList controllersList
updateWorkspaceControllers :: WorkspacesIO ()
updateWorkspaceControllers = do
WorkspacesContext
{ controllersVar = controllersRef
, workspacesVar = workspacesRef
, workspacesWidget = cont
, workspacesConfig = cfg
} <- ask
workspacesMap <- lift $ MV.readMVar workspacesRef
controllersMap <- lift $ MV.readMVar controllersRef
let newWorkspacesSet = M.keysSet workspacesMap
existingWorkspacesSet = M.keysSet controllersMap
when (existingWorkspacesSet /= newWorkspacesSet) $ do
let addWorkspaces = Set.difference newWorkspacesSet existingWorkspacesSet
removeWorkspaces = Set.difference existingWorkspacesSet newWorkspacesSet
builder = widgetBuilder cfg
_ <- updateVar controllersRef $ \controllers -> do
let oldRemoved = F.foldl (flip M.delete) controllers removeWorkspaces
buildController idx = builder <$> M.lookup idx workspacesMap
buildAndAddController theMap idx =
maybe (return theMap) (>>= return . flip (M.insert idx) theMap)
(buildController idx)
foldM buildAndAddController oldRemoved $ Set.toList addWorkspaces
-- Clear the container and repopulate it
lift $ Gtk.containerForeach cont (Gtk.containerRemove cont)
addWidgetsToTopLevel
rateLimitFn
:: forall req resp.
WorkspacesContext
-> (req -> IO resp)
-> ResultsCombiner req resp
-> IO (req -> IO resp)
rateLimitFn context =
let limit = (updateRateLimitMicroseconds $ workspacesConfig context)
rate = fromMicroseconds limit :: Microsecond in
generateRateLimitedFunction $ PerInvocation rate
onWorkspaceUpdate :: WorkspacesContext -> IO (Event -> IO ())
onWorkspaceUpdate context = do
rateLimited <- rateLimitFn context doUpdate combineRequests
let withLog event = do
case event of
PropertyEvent _ _ _ _ _ atom _ _ ->
wLog DEBUG $ printf "Event %s" $ show atom
_ -> return ()
void $ forkIO $ rateLimited event
return withLog
where
combineRequests _ b = Just (b, const ((), ()))
doUpdate _ = postGUIASync $ runReaderT updateAllWorkspaceWidgets context
onIconChanged :: (Set.Set X11Window -> IO ()) -> Event -> IO ()
onIconChanged handler event =
case event of
PropertyEvent { ev_window = wid } -> do
wLog DEBUG $ printf "Icon changed event %s" $ show wid
handler $ Set.singleton wid
_ -> return ()
onIconsChanged :: WorkspacesContext -> IO (Set.Set X11Window -> IO ())
onIconsChanged context = rateLimitFn context onIconsChanged' combineRequests
where
combineRequests windows1 windows2 =
Just (Set.union windows1 windows2, const ((), ()))
onIconsChanged' wids = do
wLog DEBUG $ printf "Icon update execute %s" $ show wids
postGUIASync $ flip runReaderT context $
doWidgetUpdate
(\idx c ->
wLog DEBUG (printf "Updating %s icons." $ show idx) >>
updateWidget c (IconUpdate $ Set.toList wids))
initializeWWC ::
WorkspaceWidgetController a => a -> Workspace -> ReaderT WorkspacesContext IO WWC
initializeWWC controller ws =
WWC <$> updateWidget controller (WorkspaceUpdate ws)
-- | A WrappingController can be used to wrap some child widget with another
-- abitrary widget.
data WrappingController = WrappingController
{ wrappedWidget :: Gtk.Widget
, wrappedController :: WWC
}
instance WorkspaceWidgetController WrappingController where
getWidget = lift . Gtk.toWidget . wrappedWidget
updateWidget wc update = do
updated <- updateWidget (wrappedController wc) update
return wc { wrappedController = updated }
data WorkspaceContentsController = WorkspaceContentsController
{ containerWidget :: Gtk.Widget
, contentsControllers :: [WWC]
}
buildContentsController :: [ControllerConstructor] -> ControllerConstructor
buildContentsController constructors ws = do
controllers <- mapM ($ ws) constructors
ctx <- ask
tempController <- lift $ do
cons <- Gtk.boxNew Gtk.OrientationHorizontal 0
mapM_ (flip runReaderT ctx . getWidget >=> Gtk.containerAdd cons) controllers
outerBox <- Gtk.toWidget cons >>= buildPadBox
_ <- widgetSetClassGI cons "contents"
widget <- Gtk.toWidget outerBox
return
WorkspaceContentsController
{ containerWidget = widget
, contentsControllers = controllers
}
initializeWWC tempController ws
defaultBuildContentsController :: ControllerConstructor
defaultBuildContentsController =
buildContentsController [buildLabelController, buildIconController]
bottomLeftAlignedBoxWrapper :: T.Text -> ControllerConstructor -> ControllerConstructor
bottomLeftAlignedBoxWrapper boxClass constructor ws = do
controller <- constructor ws
widget <- getWidget controller
ebox <- Gtk.eventBoxNew
_ <- widgetSetClassGI ebox boxClass
Gtk.widgetSetHalign ebox Gtk.AlignStart
Gtk.widgetSetValign ebox Gtk.AlignEnd
Gtk.containerAdd ebox widget
wrapped <- Gtk.toWidget ebox
let wrappingController = WrappingController
{ wrappedWidget = wrapped
, wrappedController = controller
}
initializeWWC wrappingController ws
buildLabelOverlayController :: ControllerConstructor
buildLabelOverlayController =
buildOverlayContentsController
[buildIconController]
[bottomLeftAlignedBoxWrapper "overlay-box" buildLabelController]
buildOverlayContentsController ::
[ControllerConstructor] -> [ControllerConstructor] -> ControllerConstructor
buildOverlayContentsController mainConstructors overlayConstructors ws = do
controllers <- mapM ($ ws) mainConstructors
overlayControllers <- mapM ($ ws) overlayConstructors
ctx <- ask
tempController <- lift $ do
mainContents <- Gtk.boxNew Gtk.OrientationHorizontal 0
mapM_ (flip runReaderT ctx . getWidget >=> Gtk.containerAdd mainContents)
controllers
outerBox <- Gtk.toWidget mainContents >>= buildPadBox
_ <- widgetSetClassGI mainContents "contents"
overlay <- Gtk.overlayNew
Gtk.containerAdd overlay outerBox
mapM_ (flip runReaderT ctx . getWidget >=>
Gtk.overlayAddOverlay overlay) overlayControllers
widget <- Gtk.toWidget overlay
return
WorkspaceContentsController
{ containerWidget = widget
, contentsControllers = controllers ++ overlayControllers
}
initializeWWC tempController ws
instance WorkspaceWidgetController WorkspaceContentsController where
getWidget = return . containerWidget
updateWidget cc update = do
WorkspacesContext {} <- ask
case update of
WorkspaceUpdate newWorkspace ->
lift $ setWorkspaceWidgetStatusClass newWorkspace $ containerWidget cc
_ -> return ()
newControllers <- mapM (`updateWidget` update) $ contentsControllers cc
return cc {contentsControllers = newControllers}
updateWidgetX11 cc update = do
newControllers <- mapM (`updateWidgetX11` update) $ contentsControllers cc
return cc {contentsControllers = newControllers}
newtype LabelController = LabelController { label :: Gtk.Label }
buildLabelController :: ControllerConstructor
buildLabelController ws = do
tempController <- lift $ do
lbl <- Gtk.labelNew Nothing
_ <- widgetSetClassGI lbl "workspace-label"
return LabelController { label = lbl }
initializeWWC tempController ws
instance WorkspaceWidgetController LabelController where
getWidget = lift . Gtk.toWidget . label
updateWidget lc (WorkspaceUpdate newWorkspace) = do
WorkspacesContext { workspacesConfig = cfg } <- ask
labelText <- labelSetter cfg newWorkspace
lift $ do
Gtk.labelSetMarkup (label lc) $ T.pack labelText
setWorkspaceWidgetStatusClass newWorkspace $ label lc
return lc
updateWidget lc _ = return lc
data IconWidget = IconWidget
{ iconContainer :: Gtk.EventBox
, iconImage :: Gtk.Image
, iconWindow :: MV.MVar (Maybe WindowData)
, iconForceUpdate :: IO ()
}
getPixbufForIconWidget :: Bool
-> MV.MVar (Maybe WindowData)
-> Int32
-> WorkspacesIO (Maybe Gdk.Pixbuf)
getPixbufForIconWidget transparentOnNone dataVar size = do
ctx <- ask
let tContext = taffyContext ctx
getPBFromData = getWindowIconPixbuf $ workspacesConfig ctx
getPB' = runMaybeT $
MaybeT (lift $ MV.readMVar dataVar) >>= MaybeT . getPBFromData size
getPB = if transparentOnNone
then maybeTCombine getPB' (Just <$> pixBufFromColor size 0)
else getPB'
lift $ runReaderT getPB tContext
buildIconWidget :: Bool -> Workspace -> WorkspacesIO IconWidget
buildIconWidget transparentOnNone ws = do
ctx <- ask
lift $ do
windowVar <- MV.newMVar Nothing
img <- Gtk.imageNew
refreshImage <-
autoSizeImage img
(flip runReaderT ctx . getPixbufForIconWidget transparentOnNone windowVar)
Gtk.OrientationHorizontal
ebox <- Gtk.eventBoxNew
_ <- widgetSetClassGI img "window-icon"
_ <- widgetSetClassGI ebox "window-icon-container"
Gtk.containerAdd ebox img
_ <-
Gtk.onWidgetButtonPressEvent ebox $
const $ liftIO $ do
info <- MV.readMVar windowVar
case info of
Just updatedInfo ->
flip runReaderT ctx $
liftX11Def () $ focusWindow $ windowId updatedInfo
_ -> liftIO $ void $ switch ctx (workspaceIdx ws)
return True
return
IconWidget
{ iconContainer = ebox
, iconImage = img
, iconWindow = windowVar
, iconForceUpdate = refreshImage
}
data IconController = IconController
{ iconsContainer :: Gtk.Box
, iconImages :: [IconWidget]
, iconWorkspace :: Workspace
}
buildIconController :: ControllerConstructor
buildIconController ws = do
tempController <-
lift $ do
hbox <- Gtk.boxNew Gtk.OrientationHorizontal 0
return
IconController
{iconsContainer = hbox, iconImages = [], iconWorkspace = ws}
initializeWWC tempController ws
instance WorkspaceWidgetController IconController where
getWidget = lift . Gtk.toWidget . iconsContainer
updateWidget ic (WorkspaceUpdate newWorkspace) = do
newImages <- updateImages ic newWorkspace
return ic { iconImages = newImages, iconWorkspace = newWorkspace }
updateWidget ic (IconUpdate updatedIcons) =
updateWindowIconsById ic updatedIcons >> return ic
updateWindowIconsById ::
IconController -> [X11Window] -> WorkspacesIO ()
updateWindowIconsById ic windowIds =
mapM_ maybeUpdateWindowIcon $ iconImages ic
where
maybeUpdateWindowIcon widget =
do
info <- lift $ MV.readMVar $ iconWindow widget
when (maybe False (flip elem windowIds . windowId) info) $
updateIconWidget ic widget info
scaledWindowIconPixbufGetter :: WindowIconPixbufGetter -> WindowIconPixbufGetter
scaledWindowIconPixbufGetter getter size =
getter size >=>
lift . traverse (scalePixbufToSize size Gtk.OrientationHorizontal)
constantScaleWindowIconPixbufGetter ::
Int32 -> WindowIconPixbufGetter -> WindowIconPixbufGetter
constantScaleWindowIconPixbufGetter constantSize getter =
const $ scaledWindowIconPixbufGetter getter constantSize
handleIconGetterException :: WindowIconPixbufGetter -> WindowIconPixbufGetter
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
getWindowIconPixbufFromEWMH :: WindowIconPixbufGetter
getWindowIconPixbufFromEWMH = handleIconGetterException $ \size windowData ->
runX11Def Nothing (getIconPixBufFromEWMH size $ windowId windowData)
getWindowIconPixbufFromClass :: WindowIconPixbufGetter
getWindowIconPixbufFromClass = handleIconGetterException $ \size windowData ->
lift $ getWindowIconFromClasses size (windowClass windowData)
getWindowIconPixbufFromDesktopEntry :: WindowIconPixbufGetter
getWindowIconPixbufFromDesktopEntry = handleIconGetterException $ \size windowData ->
getWindowIconFromDesktopEntryByClasses size (windowClass windowData)
getWindowIconPixbufFromChrome :: WindowIconPixbufGetter
getWindowIconPixbufFromChrome _ windowData =
getPixBufFromChromeData $ windowId windowData
defaultGetWindowIconPixbuf :: WindowIconPixbufGetter
defaultGetWindowIconPixbuf =
scaledWindowIconPixbufGetter unscaledDefaultGetWindowIconPixbuf
unscaledDefaultGetWindowIconPixbuf :: WindowIconPixbufGetter
unscaledDefaultGetWindowIconPixbuf =
getWindowIconPixbufFromDesktopEntry <|||>
getWindowIconPixbufFromClass <|||>
getWindowIconPixbufFromEWMH
addCustomIconsToDefaultWithFallbackByPath
:: (WindowData -> Maybe FilePath)
-> FilePath
-> WindowIconPixbufGetter
addCustomIconsToDefaultWithFallbackByPath getCustomIconPath fallbackPath =
addCustomIconsAndFallback
getCustomIconPath
(const $ lift $ getPixbufFromFilePath fallbackPath)
unscaledDefaultGetWindowIconPixbuf
addCustomIconsAndFallback
:: (WindowData -> Maybe FilePath)
-> (Int32 -> TaffyIO (Maybe Gdk.Pixbuf))
-> WindowIconPixbufGetter
-> WindowIconPixbufGetter
addCustomIconsAndFallback getCustomIconPath fallback defaultGetter =
scaledWindowIconPixbufGetter $
getCustomIcon <|||> defaultGetter <|||> (\s _ -> fallback s)
where
getCustomIcon :: Int32 -> WindowData -> TaffyIO (Maybe Gdk.Pixbuf)
getCustomIcon _ wdata =
lift $
maybe (return Nothing) getPixbufFromFilePath $ getCustomIconPath wdata
-- | Sort windows by top-left corner position.
sortWindowsByPosition :: [WindowData] -> WorkspacesIO [WindowData]
sortWindowsByPosition wins = do
let getGeometryWorkspaces w = getDisplay >>= liftIO . (`safeGetGeometry` w)
getGeometries = mapM
(forkM return
((((sel2 &&& sel3) <$>) .) getGeometryWorkspaces) .
windowId)
wins
windowGeometries <- liftX11Def [] getGeometries
let getLeftPos wd =
fromMaybe (999999999, 99999999) $ lookup (windowId wd) windowGeometries
compareWindowData a b =
compare
(windowMinimized a, getLeftPos a)
(windowMinimized b, getLeftPos b)
return $ sortBy compareWindowData wins
-- | Sort windows in reverse _NET_CLIENT_LIST_STACKING order.
-- Starting in xmonad-contrib 0.17.0, this is effectively focus history, active first.
-- Previous versions erroneously stored focus-sort-order in _NET_CLIENT_LIST.
sortWindowsByStackIndex :: [WindowData] -> WorkspacesIO [WindowData]
sortWindowsByStackIndex wins = do
stackingWindows <- liftX11Def [] getWindowsStacking
let getStackIdx wd = fromMaybe (-1) $ elemIndex (windowId wd) stackingWindows
compareWindowData a b = compare (getStackIdx b) (getStackIdx a)
return $ sortBy compareWindowData wins
updateImages :: IconController -> Workspace -> WorkspacesIO [IconWidget]
updateImages ic ws = do
WorkspacesContext {workspacesConfig = cfg} <- ask
sortedWindows <- iconSort cfg $ windows ws
wLog DEBUG $ printf "Updating images for %s" (show ws)
let updateIconWidget' getImageAction wdata = do
iconWidget <- getImageAction
_ <- updateIconWidget ic iconWidget wdata
return iconWidget
existingImages = map return $ iconImages ic
buildAndAddIconWidget transparentOnNone = do
iw <- buildIconWidget transparentOnNone ws
lift $ Gtk.containerAdd (iconsContainer ic) $ iconContainer iw
return iw
infiniteImages =
existingImages ++
replicate (minIcons cfg - length existingImages)
(buildAndAddIconWidget True) ++
repeat (buildAndAddIconWidget False)
windowCount = length $ windows ws
maxNeeded = maybe windowCount (min windowCount) $ maxIcons cfg
newImagesNeeded = length existingImages < max (minIcons cfg) maxNeeded
-- XXX: Only one of the two things being zipped can be an infinite list,
-- which is why this newImagesNeeded contortion is needed.
imgSrcs =
if newImagesNeeded
then infiniteImages
else existingImages
getImgs = maybe imgSrcs (`take` imgSrcs) $ maxIcons cfg
justWindows = map Just sortedWindows
windowDatas =
if newImagesNeeded
then justWindows ++
replicate (minIcons cfg - length justWindows) Nothing
else justWindows ++ repeat Nothing
newImgs <-
zipWithM updateIconWidget' getImgs windowDatas
when newImagesNeeded $ lift $ Gtk.widgetShowAll $ iconsContainer ic
return newImgs
getWindowStatusString :: WindowData -> T.Text
getWindowStatusString windowData = T.toLower $ T.pack $
case windowData of
WindowData { windowMinimized = True } -> "minimized"
WindowData { windowActive = True } -> show Active
WindowData { windowUrgent = True } -> show Urgent
_ -> "normal"
possibleStatusStrings :: [T.Text]
possibleStatusStrings =
map
(T.toLower . T.pack)
[show Active, show Urgent, "minimized", "normal", "inactive"]
updateIconWidget
:: IconController
-> IconWidget
-> Maybe WindowData
-> WorkspacesIO ()
updateIconWidget _ IconWidget
{ iconContainer = iconButton
, iconWindow = windowRef
, iconForceUpdate = updateIcon
} windowData = do
let statusString = maybe "inactive" getWindowStatusString windowData :: T.Text
title = T.pack . windowTitle <$> windowData
setIconWidgetProperties =
updateWidgetClasses iconButton [statusString] possibleStatusStrings
void $ updateVar windowRef $ const $ return windowData
Gtk.widgetSetTooltipText iconButton title
lift $ updateIcon >> setIconWidgetProperties
data WorkspaceButtonController = WorkspaceButtonController
{ button :: Gtk.EventBox
, buttonWorkspace :: Workspace
, contentsController :: WWC
}
buildButtonController :: ParentControllerConstructor
buildButtonController contentsBuilder workspace = do
cc <- contentsBuilder workspace
workspacesRef <- asks workspacesVar
ctx <- ask
widget <- getWidget cc
lift $ do
ebox <- Gtk.eventBoxNew
Gtk.containerAdd ebox widget
Gtk.eventBoxSetVisibleWindow ebox False
_ <-
Gtk.onWidgetScrollEvent ebox $ \scrollEvent -> do
dir <- Gdk.getEventScrollDirection scrollEvent
workspaces <- liftIO $ MV.readMVar workspacesRef
let switchOne a =
liftIO $
flip runReaderT ctx $
liftX11Def
()
(switchOneWorkspace a (length (M.toList workspaces) - 1)) >>
return True
case dir of
Gdk.ScrollDirectionUp -> switchOne True
Gdk.ScrollDirectionLeft -> switchOne True
Gdk.ScrollDirectionDown -> switchOne False
Gdk.ScrollDirectionRight -> switchOne False
_ -> return False
_ <- Gtk.onWidgetButtonPressEvent ebox $ const $ switch ctx $ workspaceIdx workspace
return $
WWC
WorkspaceButtonController
{ button = ebox, buttonWorkspace = workspace, contentsController = cc }
switch :: (MonadIO m) => WorkspacesContext -> WorkspaceId -> m Bool
switch ctx idx = do
liftIO $ flip runReaderT ctx $ liftX11Def () $ switchToWorkspace idx
return True
instance WorkspaceWidgetController WorkspaceButtonController
where
getWidget wbc = lift $ Gtk.toWidget $ button wbc
updateWidget wbc update = do
newContents <- updateWidget (contentsController wbc) update
return wbc { contentsController = newContents }
taffybar-4.0.1/src/System/Taffybar/Widget/WttrIn.hs 0000644 0000000 0000000 00000005623 07346545000 020330 0 ustar 00 0000000 0000000 {-# LANGUAGE OverloadedStrings #-}
-- | This is a simple weather widget that polls wttr.in to retrieve the weather,
-- instead of relying on noaa data.
--
-- Useful if NOAA data doesn't cover your needs, or if you just like wttr.in
-- better.
--
-- For more information on how to use wttr.in, see .
module System.Taffybar.Widget.WttrIn (textWttrNew) where
import Control.Exception as E (handle)
import Control.Monad.IO.Class (MonadIO)
import Data.ByteString (ByteString)
import Data.ByteString.Lazy (toStrict)
import Data.Maybe (isJust)
import qualified Data.Text as T
import Data.Text.Encoding (decodeUtf8)
import GI.Gtk (Widget)
import Network.HTTP.Client
( HttpException,
Request (requestHeaders),
Response (responseBody, responseStatus),
defaultManagerSettings,
httpLbs,
newManager,
parseRequest,
)
import Network.HTTP.Types.Status (statusIsSuccessful)
import System.Log.Logger (Priority (ERROR), logM)
import System.Taffybar.Widget.Generic.PollingLabel (pollingLabelNew)
import Text.Regex (matchRegex, mkRegex)
-- | Creates a GTK Label widget that polls the requested wttr.in url for weather
-- information.
--
-- Not compatible with image endpoints and binary data, such as the %.png%
-- endpoints.
--
-- > -- Yields a label with the text "London: ⛅️ +72°F". Updates every 60
-- > -- seconds.
-- > textWttrNew "http://wttr.in/London?format=3" 60
textWttrNew ::
MonadIO m =>
-- | URL. All non-alphanumeric characters must be properly %-encoded.
String ->
-- | Update Interval (in seconds)
Double ->
m Widget
textWttrNew url interval = pollingLabelNew interval (callWttr url)
-- | IO Action that calls wttr.in as per the user's request.
callWttr :: String -> IO T.Text
callWttr url =
let unknownLocation rsp =
-- checks for a common wttr.in bug
case T.stripPrefix "Unknown location; please try" rsp of
Nothing -> False
Just strippedRsp -> T.length strippedRsp < T.length rsp
isImage = isJust . matchRegex (mkRegex ".png")
getResponseData r =
( statusIsSuccessful $ responseStatus r,
toStrict $ responseBody r
)
in do
manager <- newManager defaultManagerSettings
request <- parseRequest url
(isOk, response) <-
handle
logException
( getResponseData
<$> httpLbs
(request {requestHeaders = [("User-Agent", "curl")]})
manager
)
let body = decodeUtf8 response
return $
if not isOk || isImage url || unknownLocation body
then "✨"
else body
-- Logs an Http Exception and returns wttr.in's weather unknown label.
logException :: HttpException -> IO (Bool, ByteString)
logException e = do
let errmsg = show e
logM
"System.Taffybar.Widget.WttrIn"
ERROR
("Warning: Couldn't call wttr.in. \n" ++ errmsg)
return (False, "✨")
taffybar-4.0.1/src/System/Taffybar/Widget/XDGMenu/ 0000755 0000000 0000000 00000000000 07346545000 020006 5 ustar 00 0000000 0000000 taffybar-4.0.1/src/System/Taffybar/Widget/XDGMenu/Menu.hs 0000644 0000000 0000000 00000011044 07346545000 021246 0 ustar 00 0000000 0000000 -----------------------------------------------------------------------------
-- |
-- Module : System.Taffybar.Widget.XDGMenu.Menu
-- Copyright : 2017 Ulf Jasper
-- License : BSD3-style (see LICENSE)
--
-- Maintainer : Ulf Jasper
-- Stability : unstable
-- Portability : unportable
--
-- Implementation of version 1.1 of the freedesktop "Desktop Menu
-- Specification", see
-- https://specifications.freedesktop.org/menu-spec/menu-spec-1.1.html
--
-- See also 'MenuWidget'.
-----------------------------------------------------------------------------
module System.Taffybar.Widget.XDGMenu.Menu
( Menu(..)
, MenuEntry(..)
, buildMenu
, getApplicationEntries
) where
import Data.Char (toLower)
import Data.List
import Data.Maybe
import qualified Data.Text as T
import System.Environment.XDG.DesktopEntry
import System.Taffybar.Information.XDG.Protocol
-- | Displayable menu
data Menu = Menu
{ fmName :: String
, fmComment :: String
, fmIcon :: Maybe String
, fmSubmenus :: [Menu]
, fmEntries :: [MenuEntry]
, fmOnlyUnallocated :: Bool
} deriving (Eq, Show)
-- | Displayable menu entry
data MenuEntry = MenuEntry
{ feName :: T.Text
, feComment :: T.Text
, feCommand :: String
, feIcon :: Maybe T.Text
} deriving (Eq, Show)
-- | Fetch menus and desktop entries and assemble the menu.
buildMenu :: Maybe String -> IO Menu
buildMenu mMenuPrefix = do
mMenuDes <- readXDGMenu mMenuPrefix
case mMenuDes of
Nothing -> return $ Menu "???" "Parsing failed" Nothing [] [] False
Just (menu, des) -> do
dt <- getXDGDesktop
dirDirs <- getDirectoryDirs
langs <- getPreferredLanguages
(fm, ae) <- xdgToMenu dt langs dirDirs des menu
let fm' = fixOnlyUnallocated ae fm
return fm'
-- | Convert xdg menu to displayable menu
xdgToMenu
:: String
-> [String]
-> [FilePath]
-> [DesktopEntry]
-> XDGMenu
-> IO (Menu, [MenuEntry])
xdgToMenu desktop langs dirDirs des xm = do
dirEntry <- getDirectoryEntry dirDirs (xmDirectory xm)
mas <- mapM (xdgToMenu desktop langs dirDirs des) (xmSubmenus xm)
let (menus, subaes) = unzip mas
menus' = sortBy (\fm1 fm2 -> compare (map toLower $ fmName fm1)
(map toLower $ fmName fm2)) menus
entries = map (xdgToMenuEntry langs) $
-- hide NoDisplay
filter (not . deNoDisplay) $
-- onlyshowin
filter (matchesOnlyShowIn desktop) $
-- excludes
filter (not . flip matchesCondition (fromMaybe None (xmExclude xm))) $
-- includes
filter (`matchesCondition` fromMaybe None (xmInclude xm)) des
onlyUnallocated = xmOnlyUnallocated xm
aes = if onlyUnallocated then [] else entries ++ concat subaes
let fm = Menu {fmName = maybe (xmName xm) (deName langs) dirEntry,
fmComment = maybe "???" (fromMaybe "???" . deComment langs) dirEntry,
fmIcon = deIcon =<< dirEntry,
fmSubmenus = menus',
fmEntries = entries,
fmOnlyUnallocated = onlyUnallocated}
return (fm, aes)
-- | Check the "only show in" logic
matchesOnlyShowIn :: String -> DesktopEntry -> Bool
matchesOnlyShowIn desktop de = matchesShowIn && notMatchesNotShowIn
where matchesShowIn = case deOnlyShowIn de of
[] -> True
desktops -> desktop `elem` desktops
notMatchesNotShowIn = case deNotShowIn de of
[] -> True
desktops -> desktop `notElem` desktops
-- | convert xdg desktop entry to displayble menu entry
xdgToMenuEntry :: [String] -> DesktopEntry -> MenuEntry
xdgToMenuEntry langs de =
MenuEntry
{feName = name, feComment = comment, feCommand = cmd, feIcon = mIcon}
where
mc =
case deCommand de of
Nothing -> Nothing
Just c -> Just $ "(" ++ c ++ ")"
comment =
T.pack $
fromMaybe "??" $
case deComment langs de of
Nothing -> mc
Just tt -> Just $ tt ++ maybe "" ("\n" ++) mc
cmd = fromMaybe "FIXME" $ deCommand de
name = T.pack $ deName langs de
mIcon = T.pack <$> deIcon de
-- | postprocess unallocated entries
fixOnlyUnallocated :: [MenuEntry] -> Menu -> Menu
fixOnlyUnallocated fes fm =
fm
{ fmEntries = entries
, fmSubmenus = map (fixOnlyUnallocated fes) (fmSubmenus fm)
}
where
entries =
if fmOnlyUnallocated fm
then filter (not . (`elem` fes)) (fmEntries fm)
else fmEntries fm
taffybar-4.0.1/src/System/Taffybar/Widget/XDGMenu/MenuWidget.hs 0000644 0000000 0000000 00000007135 07346545000 022420 0 ustar 00 0000000 0000000 -----------------------------------------------------------------------------
-- |
-- Module : System.Taffybar.Widget.XDGMenu.MenuWidget
-- Copyright : 2017 Ulf Jasper
-- License : BSD3-style (see LICENSE)
--
-- Maintainer : Ulf Jasper
-- Stability : unstable
-- Portability : unportable
--
-- MenuWidget provides a hierachical GTK menu containing all
-- applicable desktop entries found on the system. The menu is built
-- according to the version 1.1 of the XDG "Desktop Menu
-- Specification", see
-- https://specifications.freedesktop.org/menu-spec/menu-spec-1.1.html
-----------------------------------------------------------------------------
module System.Taffybar.Widget.XDGMenu.MenuWidget
(
-- * Usage
-- $usage
menuWidgetNew
)
where
import Control.Monad
import Control.Monad.IO.Class
import qualified Data.Text as T
import GI.Gtk hiding (Menu, imageMenuItemNew)
import System.Log.Logger
import System.Process
import System.Taffybar.Widget.Generic.AutoSizeImage
import System.Taffybar.Widget.Util
import System.Taffybar.Widget.XDGMenu.Menu
-- $usage
--
-- In order to use this widget add the following line to your
-- @taffybar.hs@ file:
--
-- > import System.Taffybar.Widget.XDGMenu.MenuWidget
-- > main = do
-- > let menu = menuWidgetNew $ Just "PREFIX-"
--
-- The menu will look for a file named "PREFIX-applications.menu" in the
-- (subdirectory "menus" of the) directories specified by the environment
-- variables XDG_CONFIG_HOME and XDG_CONFIG_DIRS. (If XDG_CONFIG_HOME is not set
-- or empty then $HOME/.config is used, if XDG_CONFIG_DIRS is not set or empty
-- then "/etc/xdg" is used). If no prefix is given (i.e. if you pass Nothing)
-- then the value of the environment variable XDG_MENU_PREFIX is used, if it is
-- set. If taffybar is running inside a desktop environment like Mate, Gnome,
-- XFCE etc. the environment variables XDG_CONFIG_DIRS and XDG_MENU_PREFIX
-- should be set and you may create the menu like this:
--
-- > let menu = menuWidgetNew Nothing
--
-- Now you can use @menu@ as any other Taffybar widget.
logHere :: Priority -> String -> IO ()
logHere = logM "System.Taffybar.Widget.XDGMenu.MenuWidget"
-- | Add a desktop entry to a gtk menu by appending a gtk menu item.
addItem :: (IsMenuShell msc) =>
msc -- ^ GTK menu
-> MenuEntry -- ^ Desktop entry
-> IO ()
addItem ms de = do
item <- imageMenuItemNew (feName de) (getImageForMaybeIconName (feIcon de))
setWidgetTooltipText item (feComment de)
menuShellAppend ms item
_ <- onMenuItemActivate item $ do
let cmd = feCommand de
logHere DEBUG $ "Launching '" ++ cmd ++ "'"
_ <- spawnCommand cmd
return ()
return ()
-- | Add an xdg menu to a gtk menu by appending gtk menu items and submenus.
addMenu
:: (IsMenuShell msc)
=> msc -- ^ A GTK menu
-> Menu -- ^ A menu object
-> IO ()
addMenu ms fm = do
let subMenus = fmSubmenus fm
items = fmEntries fm
when (not (null items) || not (null subMenus)) $ do
item <- imageMenuItemNew (T.pack $ fmName fm)
(getImageForMaybeIconName (T.pack <$> fmIcon fm))
menuShellAppend ms item
subMenu <- menuNew
menuItemSetSubmenu item (Just subMenu)
mapM_ (addMenu subMenu) subMenus
mapM_ (addItem subMenu) items
-- | Create a new XDG Menu Widget.
menuWidgetNew
:: MonadIO m
=> Maybe String -- ^ menu name, must end with a dash, e.g. "mate-" or "gnome-"
-> m GI.Gtk.Widget
menuWidgetNew mMenuPrefix = liftIO $ do
mb <- menuBarNew
m <- buildMenu mMenuPrefix
addMenu mb m
widgetShowAll mb
toWidget mb
taffybar-4.0.1/src/System/Taffybar/WindowIcon.hs 0000644 0000000 0000000 00000012443 07346545000 017734 0 ustar 00 0000000 0000000 module System.Taffybar.WindowIcon where
import Control.Concurrent
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.Class
import Control.Monad.Trans.Maybe
import Data.Bits
import Data.Int
import Data.List
import qualified Data.Map as M
import Data.Maybe
import qualified Data.MultiMap as MM
import Data.Ord
import qualified Data.Text as T
import Data.Word
import Foreign.Marshal.Alloc
import Foreign.Marshal.Array
import Foreign.Ptr
import Foreign.Storable
import qualified GI.GdkPixbuf.Enums as Gdk
import qualified GI.GdkPixbuf.Objects.Pixbuf as Gdk
import System.Log.Logger
import System.Taffybar.Context
import System.Taffybar.Hooks
import System.Taffybar.Information.Chrome
import System.Taffybar.Information.EWMHDesktopInfo
import System.Taffybar.Information.X11DesktopInfo
import System.Environment.XDG.DesktopEntry
import System.Taffybar.Util
import System.Taffybar.Widget.Util
type ColorRGBA = Word32
-- | Convert a C array of integer pixels in the ARGB format to the ABGR format.
-- Returns an unmanged Ptr that points to a block of memory that must be freed
-- manually.
pixelsARGBToBytesABGR
:: (Storable a, Bits a, Num a, Integral a)
=> Ptr a -> Int -> IO (Ptr Word8)
pixelsARGBToBytesABGR ptr size = do
target <- mallocArray (size * 4)
let writeIndex i = do
bits <- peekElemOff ptr i
let b = toByte bits
g = toByte $ bits `shift` (-8)
r = toByte $ bits `shift` (-16)
a = toByte $ bits `shift` (-24)
baseTarget = 4 * i
doPoke offset = pokeElemOff target (baseTarget + offset)
toByte = fromIntegral . (.&. 0xFF)
doPoke 0 r
doPoke 1 g
doPoke 2 b
doPoke 3 a
writeIndexAndNext i
| i >= size = return ()
| otherwise = writeIndex i >> writeIndexAndNext (i + 1)
writeIndexAndNext 0
return target
selectEWMHIcon :: Int32 -> [EWMHIcon] -> Maybe EWMHIcon
selectEWMHIcon imgSize icons = listToMaybe prefIcon
where
sortedIcons = sortBy (comparing ewmhHeight) icons
smallestLargerIcon =
take 1 $ dropWhile ((<= fromIntegral imgSize) . ewmhHeight) sortedIcons
largestIcon = take 1 $ reverse sortedIcons
prefIcon = smallestLargerIcon ++ largestIcon
getPixbufFromEWMHIcons :: Int32 -> [EWMHIcon] -> IO (Maybe Gdk.Pixbuf)
getPixbufFromEWMHIcons size = traverse pixBufFromEWMHIcon . selectEWMHIcon size
-- | Create a pixbuf from the pixel data in an EWMHIcon.
pixBufFromEWMHIcon :: EWMHIcon -> IO Gdk.Pixbuf
pixBufFromEWMHIcon EWMHIcon {ewmhWidth = w, ewmhHeight = h, ewmhPixelsARGB = px} = do
let width = fromIntegral w
height = fromIntegral h
rowStride = width * 4
wPtr <- pixelsARGBToBytesABGR px (w * h)
Gdk.pixbufNewFromData wPtr Gdk.ColorspaceRgb True 8
width height rowStride (Just free)
getIconPixBufFromEWMH :: Int32 -> X11Window -> X11Property (Maybe Gdk.Pixbuf)
getIconPixBufFromEWMH size x11WindowId = runMaybeT $ do
ewmhData <- MaybeT $ getWindowIconsData x11WindowId
MaybeT $ lift $ withEWMHIcons ewmhData (getPixbufFromEWMHIcons size)
-- | Create a pixbuf with the indicated RGBA color.
pixBufFromColor
:: MonadIO m
=> Int32 -> Word32 -> m Gdk.Pixbuf
pixBufFromColor imgSize c = do
pixbuf <- fromJust <$> Gdk.pixbufNew Gdk.ColorspaceRgb True 8 imgSize imgSize
Gdk.pixbufFill pixbuf c
return pixbuf
getDirectoryEntryByClass
:: String
-> 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)
return $ listToMaybe entries
getWindowIconForAllClasses
:: Monad m
=> (p -> String -> m (Maybe a)) -> p -> String -> m (Maybe a)
getWindowIconForAllClasses doOnClass size klass =
foldl combine (return Nothing) $ parseWindowClasses klass
where
combine soFar theClass =
maybeTCombine soFar (doOnClass size theClass)
getWindowIconFromDesktopEntryByClasses ::
Int32 -> String -> TaffyIO (Maybe Gdk.Pixbuf)
getWindowIconFromDesktopEntryByClasses =
getWindowIconForAllClasses getWindowIconFromDesktopEntryByClass
where getWindowIconFromDesktopEntryByClass size klass =
runMaybeT $ do
entry <- MaybeT $ getDirectoryEntryByClass klass
lift $ logPrintF "System.Taffybar.WindowIcon" DEBUG
"Using desktop entry for icon %s"
(deFilename entry, klass)
MaybeT $ lift $ getImageForDesktopEntry size entry
getWindowIconFromClasses :: Int32 -> String -> IO (Maybe Gdk.Pixbuf)
getWindowIconFromClasses =
getWindowIconForAllClasses getWindowIconFromClass
where getWindowIconFromClass size klass = loadPixbufByName size (T.pack klass)
getPixBufFromChromeData :: X11Window -> TaffyIO (Maybe Gdk.Pixbuf)
getPixBufFromChromeData window = do
imageData <- getChromeTabImageDataTable >>= lift . readMVar
X11WindowToChromeTabId x11LookupMapVar <- getX11WindowToChromeTabId
x11LookupMap <- lift $ readMVar x11LookupMapVar
return $ tabImageData <$> (M.lookup window x11LookupMap >>= flip M.lookup imageData)
taffybar-4.0.1/taffybar.cabal 0000644 0000000 0000000 00000015434 07346545000 014274 0 ustar 00 0000000 0000000 name: taffybar
version: 4.0.1
synopsis: A desktop bar similar to xmobar, but with more GUI
license: BSD3
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
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
library
default-extensions:
TupleSections
StandaloneDeriving
MonoLocalBinds
default-language: Haskell2010
build-depends: base > 3 && < 5
, ConfigFile
, HStringTemplate >= 0.8 && < 0.9
, X11 >= 1.5.0.1
, aeson
, ansi-terminal
, broadcast-chan >= 0.2.0.2
, bytestring
, conduit
, containers
, data-default
, dbus >= 1.2.11 && < 2.0.0
, dbus-hslogger >= 0.1.0.1 && < 0.2.0.0
, directory
, dyre >= 0.9.0 && < 0.10
, 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-gdkx11
, gi-glib
, gi-gtk
, gi-gtk-hs
, 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
, http-client >= 0.5
, 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.13
, split >= 0.1.4.2
, status-notifier-item >= 0.3.1.0
, stm
, template-haskell
, text
, time >= 1.9 && < 2.0
, 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
, xdg-desktop-entry
, xdg-basedir >= 0.2 && < 0.3
, xml
, xml-helpers
, xmonad
hs-source-dirs: src
pkgconfig-depends: gtk+-3.0
exposed-modules: System.Taffybar
, System.Taffybar.Auth
, System.Taffybar.Context
, System.Taffybar.DBus
, System.Taffybar.DBus.Toggle
, System.Taffybar.Example
, System.Taffybar.Hooks
, System.Taffybar.Information.Battery
, System.Taffybar.Information.CPU
, System.Taffybar.Information.CPU2
, System.Taffybar.Information.Chrome
, System.Taffybar.Information.Crypto
, System.Taffybar.Information.DiskIO
, System.Taffybar.Information.EWMHDesktopInfo
, System.Taffybar.Information.MPRIS2
, System.Taffybar.Information.Memory
, System.Taffybar.Information.Network
, System.Taffybar.Information.SafeX11
, System.Taffybar.Information.StreamInfo
, System.Taffybar.Information.X11DesktopInfo
, 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
, System.Taffybar.Widget.CPUMonitor
, System.Taffybar.Widget.CommandRunner
, System.Taffybar.Widget.Crypto
, System.Taffybar.Widget.DiskIOMonitor
, System.Taffybar.Widget.FSMonitor
, System.Taffybar.Widget.FreedesktopNotifications
, System.Taffybar.Widget.Generic.AutoSizeImage
, System.Taffybar.Widget.Generic.ChannelGraph
, System.Taffybar.Widget.Generic.ChannelWidget
, System.Taffybar.Widget.Generic.DynamicMenu
, System.Taffybar.Widget.Generic.Graph
, System.Taffybar.Widget.Generic.Icon
, System.Taffybar.Widget.Generic.PollingBar
, System.Taffybar.Widget.Generic.PollingGraph
, System.Taffybar.Widget.Generic.PollingLabel
, System.Taffybar.Widget.Generic.VerticalBar
, System.Taffybar.Widget.Layout
, System.Taffybar.Widget.MPRIS2
, System.Taffybar.Widget.NetworkGraph
, System.Taffybar.Widget.SNITray
, System.Taffybar.Widget.SimpleClock
, System.Taffybar.Widget.SimpleCommandButton
, System.Taffybar.Widget.Text.CPUMonitor
, System.Taffybar.Widget.Text.MemoryMonitor
, System.Taffybar.Widget.Text.NetworkMonitor
, System.Taffybar.Widget.Util
, System.Taffybar.Widget.Weather
, System.Taffybar.Widget.Windows
, System.Taffybar.Widget.Workspaces
, System.Taffybar.Widget.WttrIn
, System.Taffybar.Widget.XDGMenu.Menu
, System.Taffybar.Widget.XDGMenu.MenuWidget
, System.Taffybar.WindowIcon
other-modules: Paths_taffybar
, System.Taffybar.DBus.Client.MPRIS2
, System.Taffybar.DBus.Client.Params
, System.Taffybar.DBus.Client.UPower
, System.Taffybar.DBus.Client.UPowerDevice
, System.Taffybar.DBus.Client.Util
cc-options: -fPIC
ghc-options: -Wall -funbox-strict-fields -fno-warn-orphans
executable taffybar
default-language: Haskell2010
build-depends: base > 3 && < 5
, data-default
, directory
, hslogger
, optparse-applicative
, taffybar
other-modules: Paths_taffybar
hs-source-dirs: app
main-is: Main.hs
pkgconfig-depends: gtk+-3.0
ghc-options: -Wall -rtsopts -threaded
source-repository head
type: git
location: git://github.com/taffybar/taffybar.git
taffybar-4.0.1/taffybar.css 0000644 0000000 0000000 00000004762 07346545000 014024 0 ustar 00 0000000 0000000 @define-color transparent rgba(0, 0, 0, 0.0);
@define-color white #FFFFFF;
@define-color black #000000;
@define-color taffy-blue #0c7cd5;
@define-color active-window-color @white;
@define-color urgent-window-color @taffy-blue;
@define-color font-color @white;
@define-color menu-background-color @white;
@define-color menu-font-color @black;
/* Top level styling */
.taffy-window * {
/*
This removes any existing styling from UI elements. Taffybar will not
cohere with your gtk theme.
*/
all: unset;
font-family: "Noto Sans", sans-serif;
font-size: 10pt;
color: @font-color;
}
.taffy-box {
border-radius: 10px;
background-color: rgba(0, 0, 0, 0.3);
}
.inner-pad {
padding-bottom: 5px;
padding-top: 5px;
padding-left: 2px;
padding-right: 2px;
}
.contents {
padding-bottom: 4px;
padding-top: 4px;
padding-right: 2px;
padding-left: 2px;
transition: background-color .5s;
border-radius: 5px;
}
/* Workspaces styling */
.workspace-label {
padding-right: 3px;
padding-left: 2px;
font-size: 12pt;
}
.active .contents {
background-color: rgba(0, 0, 0, 0.5);
}
.visible .contents {
background-color: rgba(0, 0, 0, 0.2);
}
.window-icon-container {
transition: opacity .5s, box-shadow .5s;
opacity: 1;
}
/* This gives space for the box-shadow (they look like underlines) that follow.
This will actually affect all widgets, (not just the workspace icons), but
that is what we want since we want the icons to look the same. */
.auto-size-image, .sni-tray {
padding-top: 3px;
padding-bottom: 3px;
}
.window-icon-container.active {
box-shadow: inset 0 -3px @white;
}
.window-icon-container.urgent {
box-shadow: inset 0 -3px @urgent-window-color;
}
.window-icon-container.inactive .window-icon {
padding: 0px;
}
.window-icon-container.minimized .window-icon {
opacity: .3;
}
.window-icon {
opacity: 1;
transition: opacity .5s;
}
/* Button styling */
button {
background-color: @transparent;
border-width: 0px;
border-radius: 0px;
}
button:checked, button:hover .Contents:hover {
box-shadow: inset 0 -3px @taffy-blue;
}
/* Menu styling */
/* The ".taffy-window" prefixed selectors are needed because if they aren't present,
the top level .Taffybar selector takes precedence */
.taffy-window menuitem *, menuitem * {
color: @menu-font-color;
}
.taffy-window menuitem, menuitem {
background-color: @menu-background-color;
}
.taffy-window menuitem:hover, menuitem:hover {
background-color: @taffy-blue;
}
.taffy-window menuitem:hover > label, menuitem:hover > label {
color: @white;
}