taffybar-3.2.2/0000755000000000000000000000000007346545000011505 5ustar0000000000000000taffybar-3.2.2/CHANGELOG.md0000755000000000000000000002604407346545000013327 0ustar0000000000000000# 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-3.2.2/LICENSE0000644000000000000000000000301507346545000012511 0ustar0000000000000000Copyright (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-3.2.2/README.md0000755000000000000000000002042107346545000012766 0ustar0000000000000000# Taffybar [![Hackage](https://img.shields.io/hackage/v/taffybar.svg?logo=haskell&label=taffybar)](https://hackage.haskell.org/package/taffybar) [![Commits](https://img.shields.io/github/commits-since/taffybar/taffybar/latest-release.svg?label=unreleased%20commits)](https://github.com/taffybar/taffybar/compare/latest-release...master) [![Build Status](https://travis-ci.org/taffybar/taffybar.svg?branch=master)](https://travis-ci.org/taffybar/taffybar) [![Help Wanted](https://img.shields.io/github/issues/taffybar/taffybar/help%20wanted.svg)](https://github.com/taffybar/taffybar/labels/help%20wanted) [![Gitter chat](https://badges.gitter.im/gitterHQ/gitter.png)](https://gitter.im/taffybar/Lobby) [![License BSD3](https://img.shields.io/badge/license-BSD3-green.svg?dummy)](https://github.com/taffybar/taffybar/blob/master/LICENSE) ![https://github.com/taffybar/taffybar/blob/master/doc/screenshot.png](https://raw.githubusercontent.com/taffybar/taffybar/master/doc/screenshot.png) 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: [![Help Wanted](https://img.shields.io/github/issues/taffybar/taffybar/help%20wanted.svg)](https://github.com/taffybar/taffybar/labels/help%20wanted) [![Help Wanted](https://img.shields.io/github/issues/taffybar/taffybar/easy.svg)](https://github.com/taffybar/taffybar/labels/easy) taffybar-3.2.2/Setup.hs0000644000000000000000000000005607346545000013142 0ustar0000000000000000import Distribution.Simple main = defaultMain taffybar-3.2.2/app/0000755000000000000000000000000007346545000012265 5ustar0000000000000000taffybar-3.2.2/app/Main.hs0000644000000000000000000000303407346545000013505 0ustar0000000000000000-- | This is just a stub executable that uses dyre to read the config file and -- recompile itself. module Main ( main ) where 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 defaultTaffybarConfig else do logM "System.Taffybar" WARNING $ ( printf "No taffybar configuration file found at %s." taffyFilepath ++ " Starting with example configuration." ) startTaffybar exampleTaffybarConfig taffybar-3.2.2/dbus-xml/0000755000000000000000000000000007346545000013240 5ustar0000000000000000taffybar-3.2.2/dbus-xml/org.freedesktop.UPower.Device.xml0000755000000000000000000000450307346545000021506 0ustar0000000000000000 taffybar-3.2.2/dbus-xml/org.freedesktop.UPower.xml0000755000000000000000000000173507346545000020314 0ustar0000000000000000 taffybar-3.2.2/dbus-xml/org.mpris.MediaPlayer2.Player.xml0000755000000000000000000000217307346545000021420 0ustar0000000000000000 taffybar-3.2.2/dbus-xml/org.mpris.MediaPlayer2.xml0000755000000000000000000000053607346545000020166 0ustar0000000000000000 taffybar-3.2.2/icons/0000755000000000000000000000000007346545000012620 5ustar0000000000000000taffybar-3.2.2/icons/play.svg0000644000000000000000000000173207346545000014311 0ustar0000000000000000 taffybar-3.2.2/src/System/0000755000000000000000000000000007346545000013560 5ustar0000000000000000taffybar-3.2.2/src/System/Taffybar.hs0000644000000000000000000002033407346545000015654 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- 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 @src/System/Taffybar/Example.hs@): -- -- > {-# LANGUAGE OverloadedStrings #-} -- > 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 = defaultGraphConfig { graphDataColors = [ (0, 1, 0, 1), (1, 0, 1, 0.5)] -- > , graphLabel = Just "cpu" -- > } -- > clock = textClockNew defaultClockConfig -- > cpu = pollingGraphNew cpuCfg 0.5 cpuCallback -- > workspaces = workspacesNew defaultWorkspacesConfig -- > simpleConfig = defaultSimpleTaffyConfig -- > { startWidgets = [ workspaces ] -- > , endWidgets = [ sniTrayNew, clock, cpu ] -- > } -- > startTaffybar $ 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 rautomatically 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 -- * 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.Params TaffybarConfig taffybarDyreParams = Dyre.defaultParams { Dyre.projectName = "taffybar" , Dyre.realMain = dyreTaffybarMain , Dyre.showError = 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 } 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 cssPaths = 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 cssPaths 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'. Because this function -- will not handle recompiling taffybar automatically when taffybar.hs is -- updated, it is generally recommended that end users 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 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" cssPaths <- maybe getDefaultCSSPaths (return . return) $ cssPath config _ <- startCSS $ defaultCSS:cssPaths _ <- buildContext config Gtk.main return () taffybar-3.2.2/src/System/Taffybar/0000755000000000000000000000000007346545000015316 5ustar0000000000000000taffybar-3.2.2/src/System/Taffybar/Auth.hs0000644000000000000000000000151007346545000016550 0ustar0000000000000000{-# 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-3.2.2/src/System/Taffybar/Context.hs0000644000000000000000000003467107346545000017311 0ustar0000000000000000{-# 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 ----------------------------------------------------------------------------- module System.Taffybar.Context 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.GI.Base.ManagedPtr (unsafeCastTo) import Data.Int import Data.List import qualified Data.Map as M 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 type Taffy m v = MonadIO m => ReaderT Context m v 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 data BarConfig = BarConfig { strutConfig :: StrutConfig , widgetSpacing :: Int32 , startWidgets :: [TaffyIO Gtk.Widget] , centerWidgets :: [TaffyIO Gtk.Widget] , endWidgets :: [TaffyIO Gtk.Widget] , barId :: Unique } instance Eq BarConfig where a == b = barId a == barId b type BarConfigGetter = TaffyIO [BarConfig] data TaffybarConfig = TaffybarConfig { dbusClientParam :: Maybe DBus.Client , startupHook :: TaffyIO () , getBarConfigsParam :: BarConfigGetter , cssPath :: Maybe FilePath , errorMsg :: Maybe String } appendHook :: TaffyIO () -> TaffybarConfig -> TaffybarConfig appendHook hook config = config { startupHook = startupHook config >> hook } defaultTaffybarConfig :: TaffybarConfig defaultTaffybarConfig = TaffybarConfig { dbusClientParam = Nothing , startupHook = return () , getBarConfigsParam = return [] , cssPath = Nothing , errorMsg = Nothing } -- | 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 peices of state which are keyed by their -- types. Most new peices 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 differnt 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 buildEmptyContext :: IO Context buildEmptyContext = buildContext defaultTaffybarConfig 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 Gtk.boxSetCenterWidget box (Just centerBox) setupStrutWindow (strutConfig barConfig) window Gtk.containerAdd window box _ <- widgetSetClassGI window "taffy-window" let addWidgetWith widgetAdd buildWidget = runReaderT buildWidget thisContext >>= widgetAdd addToStart widget = Gtk.boxPackStart box widget False False 0 addToEnd widget = Gtk.boxPackEnd box widget False False 0 addToCenter widget = Gtk.boxPackStart centerBox widget False False 0 logIO DEBUG "Building start widgets" mapM_ (addWidgetWith addToStart) (startWidgets barConfig) logIO DEBUG "Building center widgets" mapM_ (addWidgetWith addToCenter) (centerWidgets barConfig) logIO DEBUG "Building end widgets" mapM_ (addWidgetWith addToEnd) (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 () 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 runX11 :: X11Property a -> TaffyIO a runX11 action = asksContextVar x11ContextVar >>= lift . runReaderT action runX11Def :: a -> X11Property a -> TaffyIO a runX11Def def prop = runX11 $ postX11RequestSyncProp prop def runX11Context :: MonadIO m => Context -> a -> X11Property a -> m a runX11Context context def prop = liftIO $ runReaderT (runX11Def def prop) context getState :: forall t. Typeable t => Taffy IO (Maybe t) getState = do stateMap <- asksContextVar contextState let maybeValue = M.lookup (typeOf (undefined :: 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 = typeOf (undefined :: 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-3.2.2/src/System/Taffybar/DBus.hs0000644000000000000000000000115007346545000016504 0ustar0000000000000000module 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-3.2.2/src/System/Taffybar/DBus/Client/0000755000000000000000000000000007346545000017371 5ustar0000000000000000taffybar-3.2.2/src/System/Taffybar/DBus/Client/MPRIS2.hs0000644000000000000000000000076207346545000020706 0ustar0000000000000000{-# 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-3.2.2/src/System/Taffybar/DBus/Client/Params.hs0000644000000000000000000000364507346545000021160 0ustar0000000000000000{-# 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-3.2.2/src/System/Taffybar/DBus/Client/UPower.hs0000644000000000000000000000100307346545000021140 0ustar0000000000000000{-# 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-3.2.2/src/System/Taffybar/DBus/Client/UPowerDevice.hs0000644000000000000000000000067707346545000022300 0ustar0000000000000000{-# 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-3.2.2/src/System/Taffybar/DBus/Client/Util.hs0000644000000000000000000000674307346545000020654 0ustar0000000000000000{-# 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-3.2.2/src/System/Taffybar/DBus/0000755000000000000000000000000007346545000016153 5ustar0000000000000000taffybar-3.2.2/src/System/Taffybar/DBus/Toggle.hs0000644000000000000000000001475107346545000017740 0ustar0000000000000000{-# 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.Environment.XDG.BaseDir import System.FilePath.Posix import System.Log.Logger import System.Taffybar.Context hiding (logIO) 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" taffyDir :: IO FilePath taffyDir = getUserDataDir "taffybar" toggleStateFile :: IO FilePath toggleStateFile = ( "toggle_state.dat") <$> taffyDir 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 $ taffyDir >>= 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-3.2.2/src/System/Taffybar/Example.hs0000644000000000000000000000626007346545000017251 0ustar0000000000000000{-# 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 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 = defaultGraphConfig { 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 = defaultWorkspacesConfig { 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 defaultClockConfig layout = layoutNew defaultLayoutConfig windowsW = windowsNew defaultWindowsConfig -- See https://github.com/taffybar/gtk-sni-tray#statusnotifierwatcher -- for a better way to set up the sni tray tray = sniTrayThatStartsWatcherEvenThoughThisIsABadWayToDoIt myConfig = defaultSimpleTaffyConfig { startWidgets = workspaces : map (>>= buildContentsBox) [ layout, windowsW ] , endWidgets = map (>>= buildContentsBox) [ batteryIconNew , clock , tray , cpu , mem , net , mpris2New ] , barPosition = Top , barPadding = 10 , barHeight = 50 , widgetSpacing = 0 } in withBatteryRefresh $ withLogServer $ withToggleServer $ toTaffyConfig myConfig taffybar-3.2.2/src/System/Taffybar/Hooks.hs0000644000000000000000000000466307346545000016746 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : System.Taffybar.Hooks -- Copyright : (c) Ivan A. Malison -- License : BSD3-style (see LICENSE) -- -- Maintainer : Ivan A. Malison -- Stability : unstable -- Portability : unportable ----------------------------------------------------------------------------- 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 newtype NetworkInfoChan = NetworkInfoChan (BroadcastChan In [(String, (Rational, Rational))]) buildInfoChan :: Double -> IO NetworkInfoChan buildInfoChan interval = do chan <- newBroadcastChan _ <- forkIO $ monitorNetworkInterfaces interval (void . writeBChan chan) return $ NetworkInfoChan chan getNetworkChan :: TaffyIO NetworkInfoChan getNetworkChan = getStateDefault $ lift $ buildInfoChan 2.0 setTaffyLogFormatter :: String -> IO () setTaffyLogFormatter loggerName = do handler <- taffyLogHandler updateGlobalLogger loggerName $ setHandlers [handler] withBatteryRefresh :: TaffybarConfig -> TaffybarConfig withBatteryRefresh = appendHook refreshBatteriesOnPropChange getDirectoryEntriesByClassName :: TaffyIO (MM.MultiMap String DesktopEntry) getDirectoryEntriesByClassName = getStateDefault readDirectoryEntriesDefault updateDirectoryEntriesCache :: TaffyIO () updateDirectoryEntriesCache = ask >>= \ctx -> void $ lift $ foreverWithDelay (60 :: Double) $ flip runReaderT ctx $ putState readDirectoryEntriesDefault readDirectoryEntriesDefault :: TaffyIO (MM.MultiMap String DesktopEntry) readDirectoryEntriesDefault = lift $ indexDesktopEntriesByClassName <$> getDirectoryEntriesDefault taffybar-3.2.2/src/System/Taffybar/Information/0000755000000000000000000000000007346545000017603 5ustar0000000000000000taffybar-3.2.2/src/System/Taffybar/Information/Battery.hs0000644000000000000000000002466607346545000021567 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} -- | This is a simple library to query the Linux UPower daemon (via DBus) for -- battery information. module System.Taffybar.Information.Battery ( -- * Types 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-3.2.2/src/System/Taffybar/Information/CPU.hs0000644000000000000000000000167207346545000020574 0ustar0000000000000000module 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-3.2.2/src/System/Taffybar/Information/CPU2.hs0000644000000000000000000000525507346545000020657 0ustar0000000000000000{-# 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-3.2.2/src/System/Taffybar/Information/Chrome.hs0000644000000000000000000001063007346545000021354 0ustar0000000000000000{-# 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 hiding (logIO) 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-3.2.2/src/System/Taffybar/Information/DiskIO.hs0000644000000000000000000000311507346545000021261 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- 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-3.2.2/src/System/Taffybar/Information/EWMHDesktopInfo.hs0000644000000000000000000002266607346545000023061 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- 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 , ewmhCurrentDesktop , ewmhDesktopNames , ewmhNumberOfDesktops , ewmhStateHidden , ewmhWMClass , ewmhWMDesktop , ewmhWMIcon , ewmhWMName , ewmhWMName2 , ewmhWMState , ewmhWMStateHidden , focusWindow , getActiveWindow , getCurrentWorkspace , getVisibleWorkspaces , getWindowClass , getWindowIconsData , getWindowMinimized , getWindowState , getWindowStateProperty , getWindowTitle , getWindows , 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, ewmhCurrentDesktop, ewmhDesktopNames, ewmhNumberOfDesktops, ewmhStateHidden, ewmhWMDesktop, ewmhWMStateHidden, ewmhWMClass, ewmhWMState, ewmhWMIcon, ewmhWMName, ewmhWMName2 :: EWMHProperty ewmhActiveWindow = "_NET_ACTIVE_WINDOW" ewmhClientList = "_NET_CLIENT_LIST" 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 , 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. getWindows :: X11Property [X11Window] getWindows = readAsListOfWindow Nothing ewmhClientList -- | 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-3.2.2/src/System/Taffybar/Information/MPRIS2.hs0000644000000000000000000000527607346545000021125 0ustar0000000000000000{-# 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.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" title <- lookupVariant "xesam:title" return (title, artists) taffybar-3.2.2/src/System/Taffybar/Information/Memory.hs0000644000000000000000000000414607346545000021414 0ustar0000000000000000module 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 (label:size:_) = words line newMemInfo = 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 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-3.2.2/src/System/Taffybar/Information/Network.hs0000644000000000000000000001207107346545000021571 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- 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-3.2.2/src/System/Taffybar/Information/SafeX11.hs0000644000000000000000000001675207346545000021322 0ustar0000000000000000{-# 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-3.2.2/src/System/Taffybar/Information/StreamInfo.hs0000644000000000000000000000635407346545000022216 0ustar0000000000000000-------------------------------------------------------------------------------- -- | -- 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-3.2.2/src/System/Taffybar/Information/X11DesktopInfo.hs0000644000000000000000000002416307346545000022664 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- 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-3.2.2/src/System/Taffybar/Information/XDG/0000755000000000000000000000000007346545000020225 5ustar0000000000000000taffybar-3.2.2/src/System/Taffybar/Information/XDG/Protocol.hs0000644000000000000000000002272307346545000022370 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- 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-3.2.2/src/System/Taffybar/LogFormatter.hs0000644000000000000000000000313407346545000020260 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- 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-3.2.2/src/System/Taffybar/SimpleConfig.hs0000644000000000000000000001334407346545000020236 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : System.Taffybar.SimpleConfig -- Copyright : (c) Ivan A. Malison -- License : BSD3-style (see LICENSE) -- -- Maintainer : Ivan A. Malison -- Stability : unstable -- Portability : unportable ----------------------------------------------------------------------------- module System.Taffybar.SimpleConfig ( SimpleTaffyConfig(..) , Position(..) , defaultSimpleTaffyConfig , simpleTaffybar , toTaffyConfig , useAllMonitors , usePrimaryMonitor ) where import qualified Control.Concurrent.MVar as MV import Control.Monad import Control.Monad.Trans.Class 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 -- | The side of the monitor at 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 this one. data SimpleTaffyConfig = SimpleTaffyConfig { -- | The xinerama/xrandr monitor number to put the bar on (default: PrimaryMonitor) monitorsAction :: TaffyIO [Int] -- | Number of pixels to reserve for the bar , barHeight :: Int -- | 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 , widgetSpacing :: Int -- | Widget constructors whose output are placed at the beginning of the bar , startWidgets :: [TaffyIO Gtk.Widget] -- | Widget constructors whose output are placed in the center of the bar , centerWidgets :: [TaffyIO Gtk.Widget] -- | Widget constructors whose output are placed at the end of the bar , endWidgets :: [TaffyIO Gtk.Widget] -- | Optional path to CSS stylesheet (loaded in addition to stylesheet found -- in XDG data directory). , cssPath :: Maybe 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 = 30 , barPadding = 0 , barPosition = Top , widgetSpacing = 5 , startWidgets = [] , centerWidgets = [] , endWidgets = [] , cssPath = Nothing , startupHook = return () } toStrutConfig :: SimpleTaffyConfig -> Int -> StrutConfig toStrutConfig SimpleTaffyConfig { barHeight = size , barPadding = padding , barPosition = pos } monitor = defaultStrutConfig { strutHeight = ExactSize $ fromIntegral size , 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)]) toTaffyConfig :: SimpleTaffyConfig -> BC.TaffybarConfig toTaffyConfig conf = defaultTaffybarConfig { BC.getBarConfigsParam = configGetter , BC.cssPath = cssPath 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 'SimpleTaffybarConfig'. simpleTaffybar :: SimpleTaffyConfig -> IO () simpleTaffybar conf = dyreTaffybar $ toTaffyConfig conf getMonitorCount :: IO Int getMonitorCount = fromIntegral <$> (screenGetDefault >>= maybe (return 0) (screenGetDisplay >=> displayGetNMonitors)) -- | Display a taffybar window on all monitors. useAllMonitors :: TaffyIO [Int] useAllMonitors = lift $ do count <- getMonitorCount return [0..count-1] -- | Display the taffybar window on the primary monitor. usePrimaryMonitor :: TaffyIO [Int] usePrimaryMonitor = return . fromMaybe 0 <$> lift (withDefaultCtx getPrimaryOutputNumber) taffybar-3.2.2/src/System/Taffybar/Support/0000755000000000000000000000000007346545000016772 5ustar0000000000000000taffybar-3.2.2/src/System/Taffybar/Support/PagerHints.hs0000644000000000000000000000763007346545000021400 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- 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-3.2.2/src/System/Taffybar/Util.hs0000644000000000000000000001137607346545000016577 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} ----------------------------------------------------------------------------- -- | -- 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 Control.Applicative import Control.Arrow ((&&&)) import Control.Concurrent import Control.Exception.Base 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.Either.Combinators import Data.GI.Base.GError import qualified Data.GI.Gtk.Threading as Gtk import qualified Data.Text as T import Data.Tuple.Sequence import qualified GI.GdkPixbuf.Objects.Pixbuf as Gdk import System.Exit (ExitCode (..)) import System.Log.Logger import qualified System.Process as P import Text.Printf 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 :: RealFrac d => d -> IO a -> IO ThreadId foreverWithDelay delay action = foreverWithVariableDelay $ action >> return delay foreverWithVariableDelay :: RealFrac d => IO d -> IO ThreadId foreverWithVariableDelay action = 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) safePixbufNewFromFile :: FilePath -> IO (Either GError Gdk.Pixbuf) safePixbufNewFromFile filepath = catchGErrorsAsLeft (Gdk.pixbufNewFromFile filepath) getPixbufFromFilePath :: FilePath -> IO (Maybe Gdk.Pixbuf) getPixbufFromFilePath filepath = do result <- safePixbufNewFromFile filepath when (isLeft result) $ logM "System.Taffybar.WindowIcon" WARNING $ printf "Failed to load icon from filepath %s" filepath return $ rightToMaybe result postGUIASync :: IO () -> IO () postGUIASync = Gtk.postGUIASync postGUISync :: IO () -> IO () postGUISync = Gtk.postGUISync taffybar-3.2.2/src/System/Taffybar/Widget.hs0000644000000000000000000000542507346545000017103 0ustar0000000000000000module 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 -- * "System.Taffybar.Widget.Decorators" , module System.Taffybar.Widget.Decorators -- * "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 import System.Taffybar.Widget.Decorators 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-3.2.2/src/System/Taffybar/Widget/0000755000000000000000000000000007346545000016541 5ustar0000000000000000taffybar-3.2.2/src/System/Taffybar/Widget/Battery.hs0000644000000000000000000001170507346545000020513 0ustar0000000000000000{-# 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 using the UPower system -- service. -- -- Currently it reports only the first battery it finds. If it does not find a -- battery, it just returns an obnoxious widget with warning text in it. Battery -- hotplugging is not supported. These more advanced features could be supported -- if there is interest. ----------------------------------------------------------------------------- module System.Taffybar.Widget.Battery ( textBatteryNew, batteryIconNew ) where import Control.Applicative import Control.Monad import Control.Monad.IO.Class import Control.Monad.Trans.Reader import Data.Int (Int64) import qualified Data.Text as T import GI.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 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 -- ^ Display format -> TaffyIO Widget textBatteryNew format = do chan <- getDisplayBatteryChan ctx <- ask let getLabelText info = formatBattInfo (getBatteryWidgetInfo info) format getBatteryInfoIO = runReaderT getDisplayBatteryInfo ctx liftIO $ do label <- getLabelText <$> getBatteryInfoIO >>= labelNew . Just let setMarkup text = postGUIASync $ labelSetMarkup label text updateWidget = setMarkup . getLabelText void $ onWidgetRealize label $ getLabelText <$> getBatteryInfoIO >>= setMarkup 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-3.2.2/src/System/Taffybar/Widget/CPUMonitor.hs0000644000000000000000000000316107346545000021075 0ustar0000000000000000-------------------------------------------------------------------------------- -- | -- 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-3.2.2/src/System/Taffybar/Widget/CommandRunner.hs0000644000000000000000000000344107346545000021647 0ustar0000000000000000{-# 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-3.2.2/src/System/Taffybar/Widget/Decorators.hs0000644000000000000000000000231507346545000021203 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module System.Taffybar.Widget.Decorators where import Control.Monad.IO.Class import qualified GI.Gtk as Gtk import System.Taffybar.Widget.Util -- | Wrap a widget with two container boxes. The inner box will have the class -- "InnerPad", and the outer box will have the class "OuterPad". 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.eventBoxNew 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-3.2.2/src/System/Taffybar/Widget/DiskIOMonitor.hs0000644000000000000000000000305607346545000021573 0ustar0000000000000000-------------------------------------------------------------------------------- -- | -- 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-3.2.2/src/System/Taffybar/Widget/FSMonitor.hs0000644000000000000000000000324507346545000020761 0ustar0000000000000000{-# 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-3.2.2/src/System/Taffybar/Widget/FreedesktopNotifications.hs0000644000000000000000000002472507346545000024114 0ustar0000000000000000{-# 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. A visual -- overhaul of the widget is coming. -- -- 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.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 } -- | 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-3.2.2/src/System/Taffybar/Widget/Generic/0000755000000000000000000000000007346545000020115 5ustar0000000000000000taffybar-3.2.2/src/System/Taffybar/Widget/Generic/AutoSizeImage.hs0000644000000000000000000001533107346545000023162 0ustar0000000000000000{-# 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-3.2.2/src/System/Taffybar/Widget/Generic/ChannelGraph.hs0000644000000000000000000000137407346545000023010 0ustar0000000000000000module 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 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-3.2.2/src/System/Taffybar/Widget/Generic/ChannelWidget.hs0000644000000000000000000000116507346545000023170 0ustar0000000000000000module 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 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-3.2.2/src/System/Taffybar/Widget/Generic/DynamicMenu.hs0000644000000000000000000000160307346545000022662 0ustar0000000000000000module 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-3.2.2/src/System/Taffybar/Widget/Generic/Graph.hs0000644000000000000000000002135707346545000021522 0ustar0000000000000000{-# 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 '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.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) 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 } -- | 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 case graphLabel cfg of Nothing -> return () Just lbl -> do l <- Gtk.labelNew (Nothing :: Maybe T.Text) Gtk.labelSetMarkup l lbl Gtk.boxPackStart box l False False 0 Gtk.widgetSetVexpand drawArea True Gtk.widgetSetVexpand box True Gtk.boxPackStart box drawArea True True 0 Gtk.widgetShowAll box giBox <- Gtk.toWidget box return (giBox, GH mv) taffybar-3.2.2/src/System/Taffybar/Widget/Generic/Icon.hs0000644000000000000000000000371607346545000021350 0ustar0000000000000000-- | 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 , pollingIconImageWidgetNew ) where import Control.Concurrent ( forkIO, threadDelay ) 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 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 = liftIO $ do icon <- imageNewFromFile path _ <- onWidgetRealize icon $ do _ <- forkIO $ forever $ do let tryUpdate = do str <- cmd postGUIASync $ imageSetFromFile icon (Just str) E.catch tryUpdate ignoreIOException threadDelay $ floor (interval * 1000000) return () putInBox icon 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-3.2.2/src/System/Taffybar/Widget/Generic/PollingBar.hs0000644000000000000000000000223407346545000022503 0ustar0000000000000000-- | 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-3.2.2/src/System/Taffybar/Widget/Generic/PollingGraph.hs0000644000000000000000000000216407346545000023042 0ustar0000000000000000-- | 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, defaultGraphConfig ) where import Control.Concurrent import qualified Control.Exception.Enclosed as E import Control.Monad import Control.Monad.IO.Class import GI.Gtk import System.Taffybar.Util import System.Taffybar.Widget.Generic.Graph pollingGraphNew :: MonadIO m => GraphConfig -> Double -> IO [Double] -> m GI.Gtk.Widget pollingGraphNew 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 -> graphAddSample graphHandle sample void $ onWidgetUnrealize graphWidget $ killThread sampleThread return graphWidget taffybar-3.2.2/src/System/Taffybar/Widget/Generic/PollingLabel.hs0000644000000000000000000000512707346545000023022 0ustar0000000000000000-- | 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-3.2.2/src/System/Taffybar/Widget/Generic/VerticalBar.hs0000644000000000000000000001417207346545000022654 0ustar0000000000000000-- | 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-3.2.2/src/System/Taffybar/Widget/Layout.hs0000644000000000000000000000745107346545000020361 0ustar0000000000000000{-# 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 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 defaultLayoutConfig -- -- now you can use @los@ as any other Taffybar widget. newtype LayoutConfig = LayoutConfig { formatLayout :: T.Text -> TaffyIO T.Text } defaultLayoutConfig :: LayoutConfig defaultLayoutConfig = LayoutConfig return -- | 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-3.2.2/src/System/Taffybar/Widget/MPRIS2.hs0000644000000000000000000001415307346545000020055 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} ----------------------------------------------------------------------------- -- | -- 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 ( mpris2New ) 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 DBus.Internal.Types import qualified DBus.TH as DBus import Data.Coerce import Data.List import qualified Data.Text as T import qualified GI.Gtk as Gtk import qualified GI.GLib as G import System.Log.Logger import System.Taffybar.Context import System.Taffybar.DBus.Client.MPRIS2 import System.Taffybar.Information.MPRIS2 import System.Environment.XDG.DesktopEntry 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" data MPRIS2PlayerWidget = MPRIS2PlayerWidget { playerLabel :: Gtk.Label , playerGrid :: Gtk.Grid } mpris2New :: TaffyIO Gtk.Widget mpris2New = asks sessionDBusClient >>= \client -> lift $ do grid <- Gtk.gridNew vFillCenter grid playerWidgetsVar <- MV.newMVar [] let newPlayerWidget :: BusName -> IO MPRIS2PlayerWidget newPlayerWidget busName = do let loadDefault size = catchGErrorsAsLeft (loadIcon size "play.svg") >>= either failure return where failure err = mprisLog WARNING "Failed to load default image: %s" err >> pixBufFromColor size 0 logErrorAndLoadDefault size err = mprisLog WARNING "Failed to get MPRIS icon: %s" err >> mprisLog WARNING "MPRIS failure for: %s" busName >> loadDefault size makeExcept :: String -> (a -> IO (Maybe b)) -> a -> ExceptT String IO b makeExcept errorString actionBuilder = ExceptT . fmap (maybeToEither errorString) . actionBuilder loadIconAtSize size = either (logErrorAndLoadDefault size) return =<< runExceptT ( ExceptT (left show <$> getDesktopEntry client busName) >>= makeExcept "Failed to get desktop entry" getDirectoryEntryDefault >>= makeExcept "Failed to get image" (getImageForDesktopEntry size) ) image <- autoSizeImageNew loadIconAtSize Gtk.OrientationHorizontal playerBox <- Gtk.gridNew label <- Gtk.labelNew Nothing Gtk.containerAdd playerBox image Gtk.containerAdd playerBox label vFillCenter playerBox Gtk.containerAdd grid playerBox Gtk.widgetSetVexpand playerBox True Gtk.widgetHide playerBox return MPRIS2PlayerWidget {playerLabel = label, playerGrid = playerBox} updatePlayerWidget children nowPlaying@NowPlaying { npBusName = busName , npStatus = status } = case lookup busName children of Nothing -> do playerWidget <- newPlayerWidget busName setNowPlaying playerWidget return $ (busName, playerWidget):children Just playerWidget -> setNowPlaying playerWidget >> return children where setNowPlaying MPRIS2PlayerWidget { playerLabel = label , playerGrid = playerBox } = do logPrintF "System.Taffybar.Widget.MPRIS2" DEBUG "Setting state %s" nowPlaying Gtk.labelSetMarkup label =<< playingText 20 30 nowPlaying if status == "Playing" then Gtk.widgetShowAll playerBox else Gtk.widgetHide playerBox updatePlayerWidgets nowPlayings playerWidgets = do newWidgets <- foldM updatePlayerWidget playerWidgets nowPlayings let existingBusNames = map npBusName nowPlayings noInfoPlayerWidgets = filter ((`notElem` existingBusNames) . fst) newWidgets mapM_ (Gtk.widgetHide . playerGrid . snd) noInfoPlayerWidgets return newWidgets updatePlayerWidgetsVar nowPlayings = postGUIASync $ MV.modifyMVar_ playerWidgetsVar $ updatePlayerWidgets nowPlayings doUpdate = getNowPlayingInfo client >>= updatePlayerWidgetsVar signalCallback _ _ _ _ = doUpdate propMatcher = matchAny { matchPath = Just "/org/mpris/MediaPlayer2" } handleNameOwnerChanged _ name _ _ = do busNames <- map (coerce . fst) <$> MV.readMVar playerWidgetsVar when (name `elem` busNames) 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 Gtk.toWidget grid playingText :: MonadIO m => Int -> Int -> NowPlaying -> m T.Text playingText artistMax songMax NowPlaying {npArtists = artists, npTitle = title} = G.markupEscapeText formattedText (-1) where formattedText = T.pack $ printf "%s - %s" (truncateString artistMax $ intercalate "," artists) (truncateString songMax title) taffybar-3.2.2/src/System/Taffybar/Widget/NetworkGraph.hs0000644000000000000000000000164207346545000021513 0ustar0000000000000000module System.Taffybar.Widget.NetworkGraph where import qualified GI.Gtk import System.Taffybar.Context import System.Taffybar.Hooks import System.Taffybar.Information.Network import System.Taffybar.Widget.Generic.ChannelGraph import System.Taffybar.Widget.Generic.Graph logScale :: Double -> Double -> Double -> Double logScale base maxValue value = logBase base (min value maxValue) / actualMax where actualMax = logBase base maxValue networkGraphNew :: GraphConfig -> Maybe [String] -> TaffyIO GI.Gtk.Widget networkGraphNew config interfaces = do NetworkInfoChan chan <- getNetworkChan let filterFn = maybe (const True) (flip elem) interfaces getUpDown = sumSpeeds . map snd . filter (filterFn . fst) toLogScale = logScale 2 (2 ** 32) toSample (up, down) = map (toLogScale . fromRational) [up, down] sampleBuilder = return . toSample . getUpDown channelGraphNew config chan sampleBuilder taffybar-3.2.2/src/System/Taffybar/Widget/SNITray.hs0000644000000000000000000000412207346545000020365 0ustar0000000000000000{-# 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 ----------------------------------------------------------------------------- module System.Taffybar.Widget.SNITray where import Control.Monad.Trans.Class import Control.Monad.Trans.Reader import Data.Ratio import qualified GI.Gtk import Graphics.UI.GIGtkStrut 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 getHost :: Bool -> TaffyIO H.Host getHost 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 -- | Build a new StatusNotifierItem tray that will share a host with any other -- trays that are constructed automatically sniTrayNewFromHost :: H.Host -> TaffyIO GI.Gtk.Widget sniTrayNewFromHost host = do client <- asks sessionDBusClient lift $ do tray <- buildTray TrayParams { trayHost = host , trayClient = client , trayOrientation = GI.Gtk.OrientationHorizontal , trayImageSize = Expand , trayIconExpand = False , trayAlignment = End , trayOverlayScale = 3 % 5 } _ <- widgetSetClassGI tray "sni-tray" GI.Gtk.widgetShowAll tray GI.Gtk.toWidget tray sniTrayNew :: TaffyIO GI.Gtk.Widget sniTrayNew = getHost False >>= sniTrayNewFromHost sniTrayThatStartsWatcherEvenThoughThisIsABadWayToDoIt :: TaffyIO GI.Gtk.Widget sniTrayThatStartsWatcherEvenThoughThisIsABadWayToDoIt = getHost True >>= sniTrayNewFromHost taffybar-3.2.2/src/System/Taffybar/Widget/SimpleClock.hs0000644000000000000000000001335707346545000021313 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE ForeignFunctionInterface #-} {-# LANGUAGE OverloadedStrings #-} module System.Taffybar.Widget.SimpleClock ( textClockNew , textClockNewWith , defaultClockConfig , ClockConfig(..) , ClockUpdateStrategy(..) ) where import Control.Monad.IO.Class 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 = defaultClockConfig { 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 } 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-3.2.2/src/System/Taffybar/Widget/SimpleCommandButton.hs0000644000000000000000000000266107346545000023026 0ustar0000000000000000{-# 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-3.2.2/src/System/Taffybar/Widget/Text/0000755000000000000000000000000007346545000017465 5ustar0000000000000000taffybar-3.2.2/src/System/Taffybar/Widget/Text/CPUMonitor.hs0000644000000000000000000000236107346545000022022 0ustar0000000000000000module 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-3.2.2/src/System/Taffybar/Widget/Text/MemoryMonitor.hs0000644000000000000000000000242707346545000022646 0ustar0000000000000000module System.Taffybar.Widget.Text.MemoryMonitor (textMemoryMonitorNew) where import Control.Monad.IO.Class ( MonadIO ) import qualified Text.StringTemplate as ST import System.Taffybar.Information.Memory import System.Taffybar.Widget.Generic.PollingLabel ( pollingLabelNew ) import qualified GI.Gtk -- | 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", "used". -> Double -- ^ Polling period in seconds. -> m GI.Gtk.Widget textMemoryMonitorNew fmt period = do label <- pollingLabelNew period callback GI.Gtk.toWidget label where callback = do info <- parseMeminfo let template = ST.newSTMP fmt let labels = ["used", "total", "free", "buffer", "cache", "rest", "used"] let actions = [memoryUsed, memoryTotal, memoryFree, memoryBuffer, memoryCache, memoryRest] actions' = map ((show . intRound).) actions let stats = [f info | f <- actions'] let template' = ST.setManyAttrib (zip labels stats) template return $ ST.render template' intRound :: Double -> Int intRound = round taffybar-3.2.2/src/System/Taffybar/Widget/Text/NetworkMonitor.hs0000644000000000000000000000456707346545000023036 0ustar0000000000000000module 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-3.2.2/src/System/Taffybar/Widget/Util.hs0000644000000000000000000001411007346545000020007 0ustar0000000000000000{-# LANGUAGE TypeApplications #-} ----------------------------------------------------------------------------- -- | -- 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.Functor ( ($>) ) 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.FilePath.Posix import System.Environment.XDG.DesktopEntry 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 <- gobjectType @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" fg) (attr "bg" bg) 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 PB.Pixbuf pixbufNewFromFileAtScaleByHeight height name = PB.pixbufNewFromFileAtScale name (-1) height True loadIcon :: Int32 -> String -> IO PB.Pixbuf loadIcon height name = (( "icons" name) <$> getDataDir) >>= pixbufNewFromFileAtScaleByHeight height setMinWidth :: (Gtk.IsWidget w, MonadIO m) => Int -> w -> m w setMinWidth width widget = liftIO $ do Gtk.widgetSetSizeRequest widget (fromIntegral width) (-1) return widget taffybar-3.2.2/src/System/Taffybar/Widget/Weather.hs0000644000000000000000000002621307346545000020500 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} -- | This module defines a simple textual weather widget that polls -- NOAA for weather data. To find your weather station, you can use -- -- -- -- 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-3.2.2/src/System/Taffybar/Widget/Windows.hs0000644000000000000000000000732607346545000020537 0ustar0000000000000000{-# 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.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 } -- | 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 (Gtk.onWidgetUnrealize label) (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-3.2.2/src/System/Taffybar/Widget/Workspaces.hs0000644000000000000000000007106307346545000021225 0ustar0000000000000000{-# 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.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 qualified Data.Foldable as F import Data.GI.Base.ManagedPtr (unsafeCastTo) import Data.Int import Data.List (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.Decorators 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 def prop = liftContext $ runX11Def def 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 , underlineHeight :: Int , underlinePadding :: 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 , underlineHeight = 4 , underlinePadding = 1 , maxIcons = Nothing , minIcons = 0 , getWindowIconPixbuf = defaultGetWindowIconPixbuf , labelSetter = return . workspaceName , showWorkspaceFn = const True , borderWidth = 2 , iconSort = sortWindowsByPosition , updateEvents = allEWMHProperties \\ [ewmhWMIcon] , updateRateLimitMicroseconds = 100000 , urgentWorkspaceState = False } 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)) 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 } WWC <$> updateWidget tempController (WorkspaceUpdate ws) defaultBuildContentsController :: ControllerConstructor defaultBuildContentsController = buildContentsController [buildLabelController, buildIconController] 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 } WWC <$> updateWidget tempController (WorkspaceUpdate 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} WWC <$> updateWidget tempController (WorkspaceUpdate 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 getWindowIconPixbufFromEWMH :: WindowIconPixbufGetter getWindowIconPixbufFromEWMH size windowData = runX11Def Nothing (getIconPixBufFromEWMH size $ windowId windowData) getWindowIconPixbufFromClass :: WindowIconPixbufGetter getWindowIconPixbufFromClass size windowData = lift $ getWindowIconFromClasses size (windowClass windowData) getWindowIconPixbufFromDesktopEntry :: WindowIconPixbufGetter getWindowIconPixbufFromDesktopEntry 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 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 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 setIconWidgetProperties = updateWidgetClasses iconButton [statusString] possibleStatusStrings void $ updateVar windowRef $ const $ return windowData 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-3.2.2/src/System/Taffybar/Widget/XDGMenu/0000755000000000000000000000000007346545000020010 5ustar0000000000000000taffybar-3.2.2/src/System/Taffybar/Widget/XDGMenu/Menu.hs0000644000000000000000000001104407346545000021250 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- 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-3.2.2/src/System/Taffybar/Widget/XDGMenu/MenuWidget.hs0000644000000000000000000000713507346545000022422 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- 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-3.2.2/src/System/Taffybar/WindowIcon.hs0000644000000000000000000001244307346545000017736 0ustar0000000000000000module 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-3.2.2/taffybar.cabal0000644000000000000000000001562507346545000014300 0ustar0000000000000000name: taffybar version: 3.2.2 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 description: Taffybar is a gtk+3 (through gi-gtk) 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. 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 , ansi-terminal , broadcast-chan >= 0.2.0.2 , bytestring , containers , dbus >= 1.2.11 && < 2.0.0 , dbus-hslogger >= 0.1.0.1 && < 0.2.0.0 , directory , dyre >= 0.8.6 && < 0.9 , either >= 4.0.0.0 , enclosed-exceptions >= 1.0.0.1 , filepath , gi-cairo , gi-cairo-connector , gi-cairo-render , gi-gdk , gi-gdkpixbuf >= 2.0.18 , gi-gdkx11 , gi-glib >= 2.0.17 , gi-gtk , gi-gtk-hs , gi-pango , gtk-sni-tray >= 0.1.5.0 , gtk-strut >= 0.1.2.1 , haskell-gi >= 0.22.6 , haskell-gi-base >= 0.22.2 , hslogger , 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 && < 0.12.0 , split >= 0.1.4.2 , status-notifier-item >= 0.3.0.5 , stm , template-haskell , text , time >= 1.8 && < 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.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.Decorators , 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.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 , 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-3.2.2/taffybar.css0000644000000000000000000000501207346545000014013 0ustar0000000000000000@define-color transparent rgba(0.0, 0.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, 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, 0.0, 0.5); } .visible .contents { background-color: rgba(0.0, 0.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; }