taffybar-3.0.0/ 0000755 0000000 0000000 00000000000 13317725701 011504 5 ustar 00 0000000 0000000 taffybar-3.0.0/LICENSE 0000644 0000000 0000000 00000002777 13317725701 012526 0 ustar 00 0000000 0000000 Copyright (c) (2011-2018), Tristan Ravitch
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.0.0/taffybar.css 0000644 0000000 0000000 00000005021 13317725701 014012 0 ustar 00 0000000 0000000 @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;
}
taffybar-3.0.0/CHANGELOG.md 0000644 0000000 0000000 00000021103 13317725701 013312 0 ustar 00 0000000 0000000 # 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.0.0/taffybar.hs.example 0000644 0000000 0000000 00000004730 13317725701 015274 0 ustar 00 0000000 0000000 -- -*- mode:haskell -*-
module Main where
import System.Taffybar
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
import System.Taffybar.Widget.Generic.PollingLabel
import System.Taffybar.Widget.Util
import System.Taffybar.Widget.Workspaces
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 =
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 = do
(_, systemLoad, totalLoad) <- cpuLoad
return [totalLoad, systemLoad]
main = do
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 = textClockNew Nothing "%a %b %_d %r" 1
layout = layoutNew defaultLayoutConfig
windows = 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, windows ]
, endWidgets = map (>>= buildContentsBox)
[ batteryIconNew
, clock
, tray
, cpu
, mem
, net
, mpris2New
]
, barPosition = Top
, barPadding = 10
, barHeight = 50
, widgetSpacing = 0
}
dyreTaffybar $ withBatteryRefresh $ withLogServer $ withToggleServer $
toTaffyConfig myConfig
taffybar-3.0.0/README.md 0000644 0000000 0000000 00000010366 13317725701 012771 0 ustar 00 0000000 0000000 # Taffybar [](https://hackage.haskell.org/package/taffybar) [](https://github.com/taffybar/taffybar/compare/latest-release...master) [](https://travis-ci.org/taffybar/taffybar) [](https://github.com/taffybar/taffybar/labels/help%20wanted) [](https://gitter.im/taffybar/Lobby) [](https://github.com/taffybar/taffybar/blob/master/LICENSE)
Taffybar is a gtk+3 [(through gi-gtk)](https://github.com/taffybar/taffybar/issues/256) based desktop
information bar, intended primarily for use with XMonad, though it can also
function alongside other EWMH compliant window managers. It is similar in spirit
to xmobar, but it differs in that it gives up some simplicity for a reasonable
helping of eye candy.
Prerequisites
-------------
Taffybar has a number of non-haskell dependencies. It is recommended that you
follow the installation instructions for
[haskell-gi](https://github.com/haskell-gi/haskell-gi) before attempting to
install taffybar.
In addition the the dependencies needed by haskell-gi, taffybar also needs the
equivalent of `libdbusmenu-gtk3-dev` and `libgirepository1.0-dev` on Debian.
Installation
------------
Taffybar itself can be installed in a number of different ways:
### Stack
Though it is admittedly a bit complicated to set up properly, using stack is the
preferred approach for installing taffybar, because it makes the build process
stable and repeatable. Even if you are unfamiliar with stack, or even haskell in
general, you should be able to get things working by using the taffybar's
quick-start script:
```
curl -sSL https://raw.githubusercontent.com/taffybar/taffybar/master/quick-start.sh | bash
```
This script will clone the taffybar repository into a subdirectory of the
default taffybar configuration directory, and copy the example cabal, stack and
taffybar.hs files into the same location. It will then install a binary
`my-taffybar` to `$HOME/.local/bin`, which can be executed to run taffybar. Note
that with this approach, running the `taffybar` binary WILL NOT work; you must
run the binary that is produced by the stack build in your local directory. The
name of the binary can be changed in the cabal file in the taffybar
configuration directory.
#### Running with stack
When you build with stack, it is recommended that you start taffybar with
`startTaffybar` rather than `dyreTaffybar`, and use
https://github.com/yamadapc/stack-run to execute the custom executable specified
by your cabal and stack files. The maintainers have plans for a better solution
(that does not require the user to use stack-run themselves) in [#158](https://github.com/taffybar/taffybar/issues/158).
### Cabal
Cabal installation is a simple matter of installing taffybar from hackage:
```
cabal install taffybar
```
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)
Contributing
------------
Taffybar desperately needs contributors. If you want to help, but don't know
where to get started you can check out our "help wanted" and "easy" labels:
[](https://github.com/taffybar/taffybar/labels/help%20wanted)
[](https://github.com/taffybar/taffybar/labels/easy)
taffybar-3.0.0/Setup.hs 0000644 0000000 0000000 00000000056 13317725701 013141 0 ustar 00 0000000 0000000 import Distribution.Simple
main = defaultMain
taffybar-3.0.0/taffybar.cabal 0000644 0000000 0000000 00000015311 13317725701 014267 0 ustar 00 0000000 0000000 name: taffybar
version: 3.0.0
synopsis: A desktop bar similar to xmobar, but with more GUI
license: BSD3
license-file: LICENSE
author: Tristan Ravitch
maintainer: tristan@nochair.net
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
taffybar.hs.example
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 gtk2hs) 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.
flag network-uri
description: network hack
default: True
library
default-extensions:
TupleSections
StandaloneDeriving
default-language: Haskell2010
build-depends: base > 3 && < 5
, ConfigFile
, HStringTemplate >= 0.8 && < 0.9
, HTTP
, X11 >= 1.5.0.1
, cairo
, containers
, dbus >= 1.0.0 && < 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-gdk
, gi-gdkpixbuf >= 2.0.16
, gi-gdkx11
, gi-glib
, gi-gtk
, gi-gtk-hs
, gi-pango
, glib
, gtk-sni-tray >= 0.1.4.0
, gtk-strut >= 0.1.2.1
, haskell-gi >= 0.21.2
, haskell-gi-base >= 0.21.1
, hslogger
, 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
, split >= 0.1.4.2
, status-notifier-item >= 0.3.0.0
, 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-basedir >= 0.2 && < 0.3
, xml
, xml-helpers
, xmonad
, xmonad-contrib
if flag(network-uri)
build-depends: network-uri >= 2.6 && < 3, network >= 2.6 && < 3
else
build-depends: network-uri < 2.6, network < 2.6
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.Hooks
, System.Taffybar.Information.Battery
, System.Taffybar.Information.CPU
, System.Taffybar.Information.CPU2
, 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.DesktopEntry
, System.Taffybar.Information.XDG.Protocol
, 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.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
, 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.0.0/dbus-xml/ 0000755 0000000 0000000 00000000000 13317725701 013237 5 ustar 00 0000000 0000000 taffybar-3.0.0/dbus-xml/org.mpris.MediaPlayer2.xml 0000644 0000000 0000000 00000000536 13317725701 020162 0 ustar 00 0000000 0000000
taffybar-3.0.0/dbus-xml/org.freedesktop.UPower.Device.xml 0000644 0000000 0000000 00000004503 13317725701 021502 0 ustar 00 0000000 0000000
taffybar-3.0.0/dbus-xml/org.mpris.MediaPlayer2.Player.xml 0000644 0000000 0000000 00000002173 13317725701 021414 0 ustar 00 0000000 0000000
taffybar-3.0.0/dbus-xml/org.freedesktop.UPower.xml 0000644 0000000 0000000 00000001735 13317725701 020310 0 ustar 00 0000000 0000000
taffybar-3.0.0/icons/ 0000755 0000000 0000000 00000000000 13317725701 012617 5 ustar 00 0000000 0000000 taffybar-3.0.0/icons/play.svg 0000644 0000000 0000000 00000001732 13317725701 014310 0 ustar 00 0000000 0000000
taffybar-3.0.0/src/ 0000755 0000000 0000000 00000000000 13317725701 012273 5 ustar 00 0000000 0000000 taffybar-3.0.0/src/System/ 0000755 0000000 0000000 00000000000 13317725701 013557 5 ustar 00 0000000 0000000 taffybar-3.0.0/src/System/Taffybar.hs 0000644 0000000 0000000 00000017353 13317725701 015662 0 ustar 00 0000000 0000000 -----------------------------------------------------------------------------
-- |
-- Module : System.Taffybar
-- Copyright : (c) Ivan A. Malison
-- License : BSD3-style (see LICENSE)
--
-- Maintainer : Ivan A. Malison
-- Stability : unstable
-- Portability : unportable
-----------------------------------------------------------------------------
module System.Taffybar
(
-- * Detail
--
-- | This is a system status bar meant for use with window managers like
-- XMonad. It is similar to xmobar, but with more visual flare and a different
-- widget set. Contributed widgets are more than welcome. The bar is drawn
-- using gtk and cairo. It is actually the simplest possible thing that could
-- plausibly work: you give Taffybar a list of GTK widgets and it will render
-- 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).
--
-- This is the real main module. The default bar should be customized to taste
-- in the config file (~/.config/taffybar/taffybar.hs). Typically, this means
-- adding widgets to the default config. A default configuration file is
-- included in the distribution, but the essentials are covered here.
-- * Config File
--
-- | The config file is just a Haskell source file that is compiled at startup
-- (if it has changed) to produce a custom executable with the desired set of
-- widgets. You will want to import this module along with the modules of any
-- widgets you want to add to the bar. Note, you can define any widgets that
-- you want in your config file or other libraries. Taffybar only cares that
-- you give it some GTK widgets to display.
--
-- Below is a fairly typical example:
--
-- > {-# 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 Nothing "%a %b %_d %H:%M" 1
-- > cpu = pollingGraphNew cpuCfg 0.5 cpuCallback
-- > workspaces = workspacesNew defaultWorkspacesConfig
-- > simpleConfig = defaultSimpleTaffyConfig
-- > { startWidgets = [ workspaces ]
-- > , endWidgets = [ sniTrayNew, clock, cpu ]
-- > }
-- > simpleTaffybar simpleConfig
--
-- This configuration creates a bar with four widgets. On the left is a widget
-- that shows information about the workspace configuration. The rightmost
-- widget is the system tray, with a clock and then a CPU graph. The clock is
-- formatted using standard strftime-style format strings (see the clock
-- module). Note that the clock is colored using Pango markup (again, see the
-- clock module).
--
-- 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.
--
-- ** A note about taffybar's dependency on DBus:
-- |
-- * If you start your window manager using a graphical login manager like gdm
-- or kdm, DBus should be started automatically for you.
--
-- * If you start xmonad with a different graphical login manager that does
-- not start DBus for you automatically, put the line @eval \`dbus-launch
-- --auto-syntax\`@ into your ~\/.xsession *before* xmonad and taffybar are
-- started. This command sets some environment variables that the two must
-- agree on.
--
-- * If you start xmonad via @startx@ or a similar command, add the
-- above command to ~\/.xinitrc
-- * 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
-- .
taffybarDyreParams
, dyreTaffybar
, startTaffybar
, dyreTaffybarMain
) 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.Taffybar.Context
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
getDefaultConfigFile :: String -> IO FilePath
getDefaultConfigFile name = do
dataDir <- getDataDir
return (dataDir name)
startCSS :: IO Gtk.CssProvider
startCSS = 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))
loadIfExists =<< getDefaultConfigFile "taffybar.css"
loadIfExists =<< getUserConfigFile "taffybar" "taffybar.css"
Just scr <- Gdk.screenGetDefault
Gtk.styleContextAddProviderForScreen scr taffybarProvider 800
return taffybarProvider
-- | 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
_ <- initThreads
_ <- Gtk.init Nothing
GIThreading.setCurrentThreadAsGUIThread
_ <- startCSS
_ <- buildContext config
Gtk.main
return ()
taffybar-3.0.0/src/System/Taffybar/ 0000755 0000000 0000000 00000000000 13317725701 015315 5 ustar 00 0000000 0000000 taffybar-3.0.0/src/System/Taffybar/DBus.hs 0000644 0000000 0000000 00000001150 13317725701 016503 0 ustar 00 0000000 0000000 module System.Taffybar.DBus
( module System.Taffybar.DBus.Toggle
, appendHook
, startTaffyLogServer
, withLogServer
, withToggleServer
) where
import Control.Monad.Trans.Class
import Control.Monad.Trans.Reader
import System.Log.DBus.Server
import System.Taffybar.Context
import System.Taffybar.DBus.Toggle
startTaffyLogServer :: TaffyIO ()
startTaffyLogServer =
asks sessionDBusClient >>= lift . startLogServer
withLogServer :: TaffybarConfig -> TaffybarConfig
withLogServer = appendHook startTaffyLogServer
withToggleServer :: TaffybarConfig -> TaffybarConfig
withToggleServer = handleDBusToggles
taffybar-3.0.0/src/System/Taffybar/Hooks.hs 0000644 0000000 0000000 00000004523 13317725701 016740 0 ustar 00 0000000 0000000 module System.Taffybar.Hooks
( module System.Taffybar.DBus
, module System.Taffybar.Hooks
, refreshBatteriesOnPropChange
) where
import Control.Applicative
import Control.Concurrent
import Control.Monad
import Control.Monad.Trans.Class
import Control.Monad.Trans.Reader
import Data.Maybe
import qualified Data.MultiMap as MM
import System.FilePath
import System.Taffybar.Context
import System.Taffybar.DBus
import System.Taffybar.Information.Battery
import System.Taffybar.Information.Network
import System.Taffybar.Information.XDG.DesktopEntry
import System.Taffybar.Util
newtype NetworkInfoChan = NetworkInfoChan (Chan [(String, (Rational, Rational))])
buildInfoChan :: Double -> IO NetworkInfoChan
buildInfoChan interval = do
chan <- newChan
_ <- forkIO $ monitorNetworkInterfaces interval $ writeChan chan
return $ NetworkInfoChan chan
getNetworkChan :: TaffyIO NetworkInfoChan
getNetworkChan = getStateDefault $ lift $ buildInfoChan 2.0
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 $
directoryEntriesByClassName <$> getDirectoryEntriesDefault
directoryEntriesByClassName
:: Foldable t
=> t DesktopEntry -> MM.MultiMap String DesktopEntry
directoryEntriesByClassName = foldl insertByClassName MM.empty
where
insertByClassName entriesMap entry =
MM.insert (getClassName entry) entry entriesMap
getFromFilename filepath =
let (_, filename) = splitFileName filepath
(_, noExtensions) = splitExtensions filename
in noExtensions
getClassName DesktopEntry {deAttributes = attributes, deFilename = filename} =
fromMaybe (getFromFilename filename) $
lookup "StartupWMClass" attributes <|>
lookup "Name" attributes
taffybar-3.0.0/src/System/Taffybar/SimpleConfig.hs 0000644 0000000 0000000 00000012547 13317725701 020241 0 ustar 00 0000000 0000000 -----------------------------------------------------------------------------
-- |
-- Module : System.Taffybar.SimpleConfig
-- Copyright : (c) Ivan A. Malison
-- License : BSD3-style (see LICENSE)
--
-- Maintainer : Ivan A. Malison
-- Stability : unstable
-- Portability : unportable
-----------------------------------------------------------------------------
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(..))
import System.Taffybar.Context hiding (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 results are placed at the beginning of the bar
, startWidgets :: [TaffyIO Gtk.Widget]
-- | Widget constructors whose results will be placed in the center of the bar
, centerWidgets :: [TaffyIO Gtk.Widget]
-- | Widget constructors whose results are placed at the end of the bar
, endWidgets :: [TaffyIO Gtk.Widget]
}
-- | 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 = []
}
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 -> TaffybarConfig
toTaffyConfig conf = defaultTaffybarConfig { getBarConfigsParam = configGetter }
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.0.0/src/System/Taffybar/Context.hs 0000644 0000000 0000000 00000030271 13317725701 017300 0 ustar 00 0000000 0000000 {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MonoLocalBinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
-----------------------------------------------------------------------------
-- |
-- 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.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 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"
logT :: MonadTrans t => System.Log.Logger.Priority -> String -> t IO ()
logT p m = lift $ logIO p m
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
, 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 []
, errorMsg = Nothing
}
data Context = Context
{ x11ContextVar :: MV.MVar X11Context
, listeners :: MV.MVar SubscriptionList
, contextState :: MV.MVar (M.Map TypeRep Value)
, existingWindows :: MV.MVar [(BarConfig, Gtk.Window)]
, sessionDBusClient :: DBus.Client
, systemDBusClient :: DBus.Client
, getBarConfigs :: BarConfigGetter
, contextBarConfig :: Maybe BarConfig
}
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
logT DEBUG "Starting X11 Handler"
startX11EventHandler
logT DEBUG "Running startup hook"
startup
logT DEBUG "Queing build windows command"
refreshTaffyWindows
logIO DEBUG "Context build finished"
return context
buildEmptyContext :: IO Context
buildEmptyContext = buildContext defaultTaffybarConfig
instance GdkX11.IsX11Window GI.Gdk.Window
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.hBoxNew False $ fromIntegral $ widgetSpacing barConfig
_ <- widgetSetClassGI box "taffy-box"
centerBox <- Gtk.hBoxNew False $ 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 gdkWindow
lift $ doLowerWindow (fromIntegral xid)
return window
refreshTaffyWindows :: TaffyIO ()
refreshTaffyWindows = liftReader postGUIASync $ do
logT 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
logT 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)
taffyFork :: ReaderT r IO () -> ReaderT r IO ()
taffyFork = void . liftReader forkIO
startX11EventHandler :: Taffy IO ()
startX11EventHandler = taffyFork $ do
c <- ask
-- The event loop needs its own X11Context to separately handle communications
-- from the X server.
lift $ withDefaultCtx $ eventLoop
(\e -> runReaderT (handleX11Event e) c)
unsubscribe :: Unique -> Taffy IO ()
unsubscribe identifier = do
listenersVar <- asks listeners
lift $ MV.modifyMVar_ listenersVar $ return . filter ((== identifier) . fst)
subscribeToAll :: Listener -> Taffy IO Unique
subscribeToAll listener = do
identifier <- lift newUnique
listenersVar <- asks listeners
let
-- 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
subscribeToEvents :: [String] -> Listener -> Taffy IO Unique
subscribeToEvents 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.0.0/src/System/Taffybar/WindowIcon.hs 0000644 0000000 0000000 00000011226 13317725701 017733 0 ustar 00 0000000 0000000 module System.Taffybar.WindowIcon where
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 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.EWMHDesktopInfo
import System.Taffybar.Information.X11DesktopInfo
import System.Taffybar.Information.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
Just pixbuf <- 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
MaybeT $ lift $ getImageForDesktopEntry size entry
getWindowIconFromClasses :: Int32 -> String -> IO (Maybe Gdk.Pixbuf)
getWindowIconFromClasses =
getWindowIconForAllClasses getWindowIconFromClass
where getWindowIconFromClass size klass = loadPixbufByName size (T.pack klass)
taffybar-3.0.0/src/System/Taffybar/Widget.hs 0000644 0000000 0000000 00000005366 13317725701 017106 0 ustar 00 0000000 0000000 module System.Taffybar.Widget
( module System.Taffybar.Widget.Util
-- * "System.Taffybar.Widget.Battery"
, module System.Taffybar.Widget.Battery
-- * "System.Taffybar.Widget.CPUMonitor"
, cpuMonitorNew
-- * "System.Taffybar.Widget.CommandRunner"
, commandRunnerNew
-- * "System.Taffybar.Widget.Decorators"
, module System.Taffybar.Widget.Decorators
-- * "System.Taffybar.Widget.DiskIOMonitor"
, dioMonitorNew
-- * "System.Taffybar.Widget.FSMonitor"
, fsMonitorNew
-- * "System.Taffybar.Widget.FreedesktopNotifications"
, Notification(..)
, NotificationConfig(..)
, defaultNotificationConfig
, notifyAreaNew
-- * "System.Taffybar.Widget.Layout"
, LayoutConfig(..)
, defaultLayoutConfig
, layoutNew
-- * "System.Taffybar.Widget.MPRIS2"
, mpris2New
-- * "System.Taffybar.Widget.NetworkGraph"
, module System.Taffybar.Widget.NetworkGraph
-- * "System.Taffybar.Widget.SNITray"
, module System.Taffybar.Widget.SNITray
-- * "System.Taffybar.Widget.SimpleClock"
, textClockNew
, textClockNewWith
, defaultClockConfig
, ClockConfig(..)
-- * "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"
, WeatherConfig(..)
, WeatherInfo(..)
, WeatherFormatter(WeatherFormatter)
, weatherNew
, weatherCustomNew
, defaultWeatherConfig
-- * "System.Taffybar.Widget.Windows"
, windowsNew
, WindowsConfig(..)
, defaultWindowsConfig
, truncatedGetActiveLabel
, truncatedGetMenuLabel
-- * "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.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.0.0/src/System/Taffybar/Util.hs 0000644 0000000 0000000 00000011553 13317725701 016573 0 ustar 00 0000000 0000000 {-# 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 GI.GLib.Constants
import GI.Gdk (threadsAddIdle)
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 a1 => a1 -> IO a -> IO ThreadId
foreverWithDelay delay action =
forkIO $ forever $ action >> threadDelay (floor $ delay * 1000000)
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) mkLeft
where mkLeft err = return $ Left err
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 action =
threadsAddIdle PRIORITY_DEFAULT_IDLE (action >> return False) >> return ()
-- XXX: This has serious problems becuase it will cause a hang if it is used
-- when already on the UI Thread
postGUISync action = do
ans <- newEmptyMVar
threadsAddIdle PRIORITY_DEFAULT_IDLE $ action >>= putMVar ans >> return False
takeMVar ans
taffybar-3.0.0/src/System/Taffybar/Auth.hs 0000644 0000000 0000000 00000001510 13317725701 016547 0 ustar 00 0000000 0000000 {-# LANGUAGE OverloadedStrings #-}
module System.Taffybar.Auth where
import Control.Arrow
import Control.Monad.IO.Class
import Data.Maybe
import System.Taffybar.Util
import Text.Regex
fieldRegex :: Regex
fieldRegex = mkRegexWithOpts "^(.*?): *(.*?)$" True True
passGet :: MonadIO m => String -> m (Either String (String, [(String, String)]))
passGet credentialName =
right (getPassComponents . lines) <$>
runCommandFromPath ["pass", "show", credentialName]
where getPassComponents passLines =
let entries =
map buildEntry $ catMaybes $
matchRegex fieldRegex <$> tail passLines
buildEntry [fieldName, fieldValue] = (fieldName, fieldValue)
buildEntry _ = ("", "")
in (head passLines, entries)
taffybar-3.0.0/src/System/Taffybar/Information/ 0000755 0000000 0000000 00000000000 13317725701 017602 5 ustar 00 0000000 0000000 taffybar-3.0.0/src/System/Taffybar/Information/CPU.hs 0000644 0000000 0000000 00000001672 13317725701 020573 0 ustar 00 0000000 0000000 module System.Taffybar.Information.CPU ( cpuLoad ) where
import Control.Concurrent ( threadDelay )
import System.IO ( IOMode(ReadMode), openFile, hGetLine, hClose )
procData :: IO [Double]
procData = do
h <- openFile "/proc/stat" ReadMode
firstLine <- hGetLine h
length firstLine `seq` return ()
hClose h
return (procParser firstLine)
procParser :: String -> [Double]
procParser = map read . tail . words
truncVal :: Double -> Double
truncVal v
| isNaN v || v < 0.0 = 0.0
| otherwise = v
-- | Return a pair with (user time, system time, total time) (read
-- from /proc/stat). The function waits for 50 ms between samples.
cpuLoad :: IO (Double, Double, Double)
cpuLoad = do
a <- procData
threadDelay 50000
b <- procData
let dif = zipWith (-) b a
tot = sum dif
pct = map (/ tot) dif
user = sum $ take 2 pct
system = pct !! 2
t = user + system
return (truncVal user, truncVal system, truncVal t)
taffybar-3.0.0/src/System/Taffybar/Information/CPU2.hs 0000644 0000000 0000000 00000005255 13317725701 020656 0 ustar 00 0000000 0000000 {-# LANGUAGE TupleSections #-}
-----------------------------------------------------------------------------
-- |
-- Module : System.Taffybar.Information.CPU2
-- Copyright : (c) José A. Romero L.
-- License : BSD3-style (see LICENSE)
--
-- Maintainer : José A. Romero L.
-- Stability : unstable
-- Portability : unportable
--
-- Provides information about used CPU times, obtained from parsing the
-- @\/proc\/stat@ file using some of the facilities included in the
-- "System.Taffybar.Information.StreamInfo" module.
-- And also provides information about the temperature of cores.
-- (Now supports only physical cpu).
--
-----------------------------------------------------------------------------
module System.Taffybar.Information.CPU2 where
import Control.Monad
import Data.List
import Data.Maybe
import Safe
import System.Directory
import System.FilePath
import System.Taffybar.Information.StreamInfo
-- | Returns a list of 5 to 7 elements containing all the values available for
-- the given core (or all of them aggregated, if "cpu" is passed).
getCPUInfo :: String -> IO [Int]
getCPUInfo = getParsedInfo "/proc/stat" parse
parse :: String -> [(String, [Int])]
parse = mapMaybe (tuplize . words) . filter (\x -> take 3 x == "cpu") . lines
tuplize :: [String] -> Maybe (String, [Int])
tuplize s = do
cpu <- s `atMay` 0
return (cpu, map (readDef (-1)) (tailSafe s))
-- | Returns a two-element list containing relative system and user times
-- calculated using two almost simultaneous samples of the @\/proc\/stat@ file
-- for the given core (or all of them aggregated, if \"cpu\" is passed).
getCPULoad :: String -> IO [Double]
getCPULoad cpu = do
load <- getLoad 0.05 $ getCPUInfo cpu
case load of
l0:l1:l2:_ -> return [ l0 + l1, l2 ]
_ -> return []
-- | Get the directory in which core temperature files are kept.
getCPUTemperatureDirectory :: IO FilePath
getCPUTemperatureDirectory =
(baseDir ) . fromMaybe "hwmon0" .
find (isPrefixOf "hwmon")
<$> listDirectory baseDir
where baseDir =
"/" "sys" "bus" "platform"
"devices" "coretemp.0" "hwmon"
readCPUTempFile :: FilePath -> IO Double
readCPUTempFile cpuTempFilePath = (/ 1000) . read <$> readFile cpuTempFilePath
getAllTemperatureFiles :: FilePath -> IO [FilePath]
getAllTemperatureFiles temperaturesDirectory =
filter (liftM2 (&&) (isPrefixOf "temp") (isSuffixOf "input")) <$>
listDirectory temperaturesDirectory
getCPUTemperatures :: IO [(String, Double)]
getCPUTemperatures = do
dir <- getCPUTemperatureDirectory
let mkPair filename = (filename,) <$> readCPUTempFile (dir filename)
getAllTemperatureFiles dir >>= mapM mkPair
taffybar-3.0.0/src/System/Taffybar/Information/X11DesktopInfo.hs 0000644 0000000 0000000 00000025051 13317725701 022660 0 ustar 00 0000000 0000000 -----------------------------------------------------------------------------
-- |
-- Module : System.Taffybar.Information.X11DesktopInfo
-- Copyright : (c) José A. Romero L.
-- License : BSD3-style (see LICENSE)
--
-- Maintainer : José A. Romero L.
-- 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
, getAtom
, getDefaultCtx
, getDisplay
, getPrimaryOutputNumber
, getVisibleTags
, getWindowState
, getWindowStateProperty
, 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 Prelude
import System.Taffybar.Information.SafeX11
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
getDisplay :: X11Property Display
getDisplay = contextDisplay <$> ask
-- | 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 window name = do
prop <- fetch getWindowProperty32 window name
case prop of
Just (x:_) -> return (fromIntegral x)
_ -> return (-1)
-- | 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 window name = do
prop <- fetch getWindowProperty32 window name
case prop of
Just xs -> return (map fromIntegral xs)
_ -> return []
-- | 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 window name = do
prop <- fetch getWindowProperty8 window name
case prop of
Just xs -> return . UTF8.decode . map fromIntegral $ xs
_ -> return []
-- | 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 window name = do
prop <- fetch getWindowProperty8 window name
case prop of
Just xs -> return (parse xs)
_ -> return []
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 window name = do
prop <- fetch getWindowProperty32 window name
case prop of
Just xs -> return $ map fromIntegral xs
_ -> return []
-- | 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
getWindowStateProperty :: X11Window -> String -> X11Property Bool
getWindowStateProperty window property = 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) "_NET_WM_STATE"
let integerToString = zip integers request
present = intersect integers $ fromMaybe [] properties
presentStrings = map (`lookup` integerToString) present
return $ catMaybes presentStrings
-- | 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
postX11RequestSyncProp :: X11Property a -> a -> X11Property a
postX11RequestSyncProp prop def = do
c <- ask
let action = runReaderT prop c
lift $ postX11RequestSyncDef def action
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
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
doLowerWindow :: X11Window -> X11Property ()
doLowerWindow window =
asks contextDisplay >>= lift . flip lowerWindow window
taffybar-3.0.0/src/System/Taffybar/Information/SafeX11.hs 0000644 0000000 0000000 00000016455 13317725701 021321 0 ustar 00 0000000 0000000 {-# LANGUAGE MultiParamTypeClasses, StandaloneDeriving, FlexibleInstances,
InterruptibleFFI, ExistentialQuantification, DeriveDataTypeable #-}
-----------------------------------------------------------------------------
-- |
-- Module : System.Taffybar.Information.SafeX11
-- Copyright : (c) Ivan A. Malison
-- License : BSD3-style (see LICENSE)
--
-- Maintainer : Ivan A. Malison
-- Stability : unstable
-- Portability : unportable
-----------------------------------------------------------------------------
module System.Taffybar.Information.SafeX11
( module Graphics.X11.Xlib
, module Graphics.X11.Xlib.Extras
, module System.Taffybar.Information.SafeX11
)
where
import Control.Concurrent
import Control.Exception
import Control.Monad
import Control.Monad.Trans.Class
import Control.Monad.Trans.Maybe (MaybeT(..))
import Data.Either.Combinators
import Data.Typeable
import Foreign hiding (void)
import Foreign.C.Types
import GHC.ForeignPtr
import Graphics.X11.Xlib
import Graphics.X11.Xlib.Extras
hiding (rawGetWindowProperty, getWindowProperty8,
getWindowProperty16, getWindowProperty32,
xGetWMHints, getWMHints, refreshKeyboardMapping)
import Prelude
import System.IO
import System.IO.Unsafe
import System.Timeout
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
putStrLn "Got error"
ee <- getErrorEvent xerrptr
print ee
handleX11Requests :: IO ()
handleX11Requests = do
IORequest {ioAction = action, ioResponse = responseChannel} <-
readChan requestQueue
res <-
catch
(maybe (Left SafeX11Exception) Right <$> timeout 500000 action)
(\e -> do
putStrLn "Got error on X11 thread"
hFlush stdout
print (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.0.0/src/System/Taffybar/Information/Network.hs 0000644 0000000 0000000 00000011737 13317725701 021600 0 ustar 00 0000000 0000000 -----------------------------------------------------------------------------
-- |
-- Module : System.Taffybar.Information.Network
-- Copyright : (c) José A. Romero L.
-- License : BSD3-style (see LICENSE)
--
-- Maintainer : José A. Romero L.
-- Stability : unstable
-- Portability : unportable
--
-- Provides information about network traffic over selected interfaces,
-- obtained from parsing the @\/proc\/net\/dev@ file using some of the
-- facilities provided by the "System.Taffybar.Information.StreamInfo" module.
--
-----------------------------------------------------------------------------
module System.Taffybar.Information.Network where
import Control.Applicative
import qualified Control.Concurrent.MVar as MV
import Control.Exception (catch, SomeException)
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.Maybe (MaybeT(..))
import Data.Maybe ( mapMaybe )
import Data.Time.Clock
import Data.Time.Clock.System
import Safe ( atMay, initSafe, readDef )
import System.Taffybar.Information.StreamInfo ( getParsedInfo )
import System.Taffybar.Util
import Prelude
networkInfoFile :: FilePath
networkInfoFile = "/proc/net/dev"
-- | Returns a two-element list containing the current number of bytes received
-- and transmitted via the given network interface (e.g. \"wlan0\"), according
-- to the contents of the @\/proc\/dev\/net@ file.
getNetInfo :: String -> IO (Maybe [Int])
getNetInfo iface = runMaybeT $ do
isInterfaceUp iface
handleFailure $ getParsedInfo networkInfoFile parseDevNet' iface
parseDevNet' :: String -> [(String, [Int])]
parseDevNet' input =
map makeList $ parseDevNet input
where makeList (a, (u, d)) = (a, [u, d])
parseDevNet :: String -> [(String, (Int, Int))]
parseDevNet = mapMaybe (getDeviceUpDown . words) . drop 2 . lines
getDeviceUpDown :: [String] -> Maybe (String, (Int, Int))
getDeviceUpDown s = do
dev <- initSafe <$> s `atMay` 0
down <- readDef (-1) <$> s `atMay` 1
up <- readDef (-1) <$> s `atMay` out
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 } =
(device, (sample, getLast sample))
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.0.0/src/System/Taffybar/Information/Battery.hs 0000644 0000000 0000000 00000022567 13317725701 021564 0 ustar 00 0000000 0000000 {-# 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 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 (Chan BatteryInfo, MVar BatteryInfo)
getDisplayBatteryInfo :: TaffyIO BatteryInfo
getDisplayBatteryInfo = do
DisplayBatteryChanVar (_, theVar) <- getDisplayBatteryChanVar
lift $ readMVar theVar
getDisplayBatteryChanVar :: TaffyIO DisplayBatteryChanVar
getDisplayBatteryChanVar =
getStateDefault $ DisplayBatteryChanVar <$> monitorDisplayBattery
getDisplayBatteryChan :: TaffyIO (Chan BatteryInfo)
getDisplayBatteryChan = do
DisplayBatteryChanVar (chan, _) <- getDisplayBatteryChanVar
return chan
updateBatteryInfo
:: Chan 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 >> writeChan chan info
warnOfFailure = batteryLogF WARNING "Failed to update battery info %s"
registerForAnyUPowerPropertiesChanged
:: (Signal -> String -> Map String Variant -> [String] -> IO ())
-> ReaderT Context IO SignalHandler
registerForAnyUPowerPropertiesChanged signalHandler = do
client <- asks systemDBusClient
lift $ DBus.registerForPropertiesChanged
client
matchAny { matchInterface = Just uPowerDeviceInterfaceName }
signalHandler
-- | Monitor the DisplayDevice for changes, writing a new "BatteryInfo" object
-- to returned "MVar" and "Chan" objects
monitorDisplayBattery :: TaffyIO (Chan BatteryInfo, MVar BatteryInfo)
monitorDisplayBattery = do
lift $ batteryLog DEBUG "Starting Battery Monitor"
client <- asks systemDBusClient
infoVar <- lift $ newMVar $ infoMapToBatteryInfo M.empty
chan <- lift newChan
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
_ <- registerForAnyUPowerPropertiesChanged 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.0.0/src/System/Taffybar/Information/MPRIS2.hs 0000644 0000000 0000000 00000005172 13317725701 021117 0 ustar 00 0000000 0000000 -----------------------------------------------------------------------------
-- |
-- 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.0.0/src/System/Taffybar/Information/Memory.hs 0000644 0000000 0000000 00000004174 13317725701 021414 0 ustar 00 0000000 0000000 module System.Taffybar.Information.Memory (
MemoryInfo(..),
parseMeminfo
) where
toMB :: String -> Double
toMB size = (read size :: Double) / 1024
data MemoryInfo = MemoryInfo
{ memoryTotal :: Double
, memoryFree :: Double
, memoryBuffer :: Double
, memoryCache :: Double
, memorySwapTotal :: Double
, memorySwapFree :: Double
, memorySwapUsed :: Double -- swapTotal - swapFree
, memorySwapUsedRatio :: Double -- swapUsed / swapTotal
, memoryAvailable :: Double -- An estimate of how much memory is available for starting new apps
, 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.0.0/src/System/Taffybar/Information/StreamInfo.hs 0000644 0000000 0000000 00000006354 13317725701 022215 0 ustar 00 0000000 0000000 --------------------------------------------------------------------------------
-- |
-- Module : System.Taffybar.Information.StreamInfo
-- Copyright : (c) José A. Romero L.
-- License : BSD3-style (see LICENSE)
--
-- Maintainer : José A. Romero L.
-- Stability : unstable
-- Portability : unportable
--
-- Generic code to poll any of the many data files maintained by the kernel in
-- POSIX systems. Provides methods for applying a custom parsing function to the
-- contents of the file and to calculate differentials across one or more values
-- provided via the file.
--
--------------------------------------------------------------------------------
module System.Taffybar.Information.StreamInfo
( getParsedInfo
, getLoad
, getAccLoad
, getTransfer
) where
import Control.Concurrent ( threadDelay )
import Data.IORef
import Data.Maybe ( fromMaybe )
-- | Apply the given parser function to the file under the given path to produce
-- a lookup map, then use the given selector as key to extract from it the
-- desired value.
getParsedInfo :: FilePath -> (String -> [(String, [a])]) -> String -> IO [a]
getParsedInfo path parser selector = do
file <- readFile path
length file `seq` return ()
return (fromMaybe [] $ lookup selector $ parser file)
truncVal :: (RealFloat a) => a -> a
truncVal v
| isNaN v || v < 0.0 = 0.0
| otherwise = v
-- | Convert the given list of Integer to a list of the ratios of each of its
-- elements against their sum.
toRatioList :: (Integral a, RealFloat b) => [a] -> [b]
toRatioList deltas = map truncVal ratios
where total = fromIntegral $ sum deltas
ratios = map ((/total) . fromIntegral) deltas
-- | Execute the given action twice with the given delay in-between and return
-- the difference between the two samples.
probe :: (Num a, RealFrac b) => IO [a] -> b -> IO [a]
probe action delay = do
a <- action
threadDelay $ round (delay * 1e6)
b <- action
return $ zipWith (-) b a
-- | Execute the given action once and return the difference between the
-- obtained sample and the one contained in the given IORef.
accProbe :: (Num a) => IO [a] -> IORef [a] -> IO [a]
accProbe action sample = do
a <- readIORef sample
b <- action
writeIORef sample b
return $ zipWith (-) b a
-- | Probe the given action and, interpreting the result as a variation in time,
-- return the speed of change of its values.
getTransfer :: (Integral a, RealFloat b) => b -> IO [a] -> IO [b]
getTransfer interval action = do
deltas <- probe action interval
return $ map (truncVal . (/interval) . fromIntegral) deltas
-- | Probe the given action and return the relative variation of each of the
-- obtained values against the whole, where the whole is calculated as the sum
-- of all the values in the probe.
getLoad :: (Integral a, RealFloat b) => b -> IO [a] -> IO [b]
getLoad interval action = toRatioList <$> probe action interval
-- | Similar to getLoad, but execute the given action only once and use the
-- given IORef to calculate the result and to save the current value, so it
-- can be reused in the next call.
getAccLoad :: (Integral a, RealFloat b) => IORef [a] -> IO [a] -> IO [b]
getAccLoad sample action = toRatioList <$> accProbe action sample
taffybar-3.0.0/src/System/Taffybar/Information/EWMHDesktopInfo.hs 0000644 0000000 0000000 00000016721 13317725701 023053 0 ustar 00 0000000 0000000 -----------------------------------------------------------------------------
-- |
-- Module : System.Taffybar.Information.EWMHDesktopInfo
-- Copyright : (c) José A. Romero L.
-- License : BSD3-style (see LICENSE)
--
-- Maintainer : José A. Romero L.
-- Stability : unstable
-- Portability : unportable
--
-- Functions to access data provided by the X11 desktop via EWHM hints. This
-- module requires that the EwmhDesktops hook from the XMonadContrib project
-- be installed in your @~\/.xmonad\/xmonad.hs@ configuration:
--
-- > import XMonad
-- > import XMonad.Hooks.EwmhDesktops (ewmh)
-- >
-- > main = xmonad $ ewmh $ ...
--
-----------------------------------------------------------------------------
module System.Taffybar.Information.EWMHDesktopInfo
( EWMHIcon(..)
, EWMHIconData
, WorkspaceIdx(..)
, X11Window -- re-exported from X11DesktopInfo
, X11WindowHandle
, focusWindow
, getActiveWindow
, getCurrentWorkspace
, getVisibleWorkspaces
, getWindowClass
, getWindowIconsData
, getWindowTitle
, getWindows
, getWorkspace
, getWorkspaceNames
, isWindowUrgent -- re-exported from X11DesktopInfo
, parseWindowClasses
, switchOneWorkspace
, switchToWorkspace
, withDefaultCtx -- re-exported from X11DesktopInfo
, withEWMHIcons
) where
import Control.Applicative
import Control.Monad.Trans.Class
import Data.List.Split
import Data.Maybe
import Data.Tuple
import Data.Word
import Debug.Trace
import Foreign.ForeignPtr
import Foreign.Marshal.Array
import Foreign.Ptr
import Foreign.Storable
import System.Taffybar.Information.SafeX11
import Prelude
import System.Taffybar.Information.X11DesktopInfo
-- | Convenience alias for a pair of the form (props, window), where props is a
-- tuple of the form (workspace index, window title, window class), and window
-- is the internal ID of an open window.
type X11WindowHandle = ((WorkspaceIdx, String, String), X11Window)
newtype WorkspaceIdx = WSIdx 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 EWMHIconData = (ForeignPtr PixelsWordType, Int)
data EWMHIcon = EWMHIcon
{ ewmhWidth :: Int
, ewmhHeight :: Int
, ewmhPixelsARGB :: Ptr PixelsWordType
} deriving (Show, Eq)
-- | Retrieve the index of the current workspace in the desktop,
-- starting from 0.
getCurrentWorkspace :: X11Property WorkspaceIdx
getCurrentWorkspace = WSIdx <$> readAsInt Nothing "_NET_CURRENT_DESKTOP"
-- | Retrieve the indexes of all currently visible workspaces
-- with the active workspace at the head of the list.
getVisibleWorkspaces :: X11Property [WorkspaceIdx]
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 [(WorkspaceIdx, String)]
getWorkspaceNames = go <$> readAsListOfString Nothing "_NET_DESKTOP_NAMES"
where go = zip [WSIdx i | i <- [0..]]
-- | Ask the window manager to switch to the workspace with the given
-- index, starting from 0.
switchToWorkspace :: WorkspaceIdx -> X11Property ()
switchToWorkspace (WSIdx idx) = do
cmd <- getAtom "_NET_CURRENT_DESKTOP"
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 :: WorkspaceIdx -> Int -> WorkspaceIdx
getPrev (WSIdx idx) end
| idx > 0 = WSIdx $ idx-1
| otherwise = WSIdx end
-- | Check for corner case and switch one workspace down
getNext :: WorkspaceIdx -> Int -> WorkspaceIdx
getNext (WSIdx idx) end
| idx < end = WSIdx $ idx+1
| otherwise = WSIdx 0
-- | Get the title of the given X11 window.
getWindowTitle :: X11Window -> X11Property String
getWindowTitle window = do
let w = Just window
prop <- readAsString w "_NET_WM_NAME"
case prop of
"" -> readAsString w "WM_NAME"
_ -> return prop
-- | Get the class of the given X11 window.
getWindowClass :: X11Window -> X11Property String
getWindowClass window = readAsString (Just window) "WM_CLASS"
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 "_NET_WM_ICON"
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.
-- 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 = trace "This should not happen parseIcons" return []
| otherwise = (thisIcon :) <$> parseIcons newSize newArr -- Keep going
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 "_NET_ACTIVE_WINDOW"
-- | Return a list of all windows
getWindows :: X11Property [X11Window]
getWindows = readAsListOfWindow Nothing "_NET_CLIENT_LIST"
-- | Return the index (starting from 0) of the workspace on which the given
-- window is being displayed.
getWorkspace :: X11Window -> X11Property WorkspaceIdx
getWorkspace window = WSIdx <$> readAsInt (Just window) "_NET_WM_DESKTOP"
-- | Ask the window manager to give focus to the given window.
focusWindow :: X11Window -> X11Property ()
focusWindow wh = do
cmd <- getAtom "_NET_ACTIVE_WINDOW"
sendWindowEvent cmd (fromIntegral wh)
taffybar-3.0.0/src/System/Taffybar/Information/DiskIO.hs 0000644 0000000 0000000 00000003115 13317725701 021260 0 ustar 00 0000000 0000000 -----------------------------------------------------------------------------
-- |
-- Module : System.Taffybar.Information.DiskIO
-- Copyright : (c) José A. Romero L.
-- License : BSD3-style (see LICENSE)
--
-- Maintainer : José A. Romero L.
-- Stability : unstable
-- Portability : unportable
--
-- Provides information about read/write operations in a given disk or
-- partition, obtained from parsing the @\/proc\/diskstats@ file with some
-- of the facilities included in the "System.Taffybar.Information.StreamInfo" module.
-----------------------------------------------------------------------------
module System.Taffybar.Information.DiskIO ( getDiskTransfer ) where
import Data.Maybe ( mapMaybe )
import Safe ( atMay, headMay, readDef )
import System.Taffybar.Information.StreamInfo ( getParsedInfo, getTransfer )
-- | Returns a two-element list containing the speed of transfer for read and
-- write operations performed in the given disk\/partition (e.g. \"sda\",
-- \"sda1\").
getDiskTransfer :: String -> IO [Double]
getDiskTransfer disk = getTransfer 0.05 $ getDiskInfo disk
-- | Returns the list of all the values available in @\/proc\/diskstats@
-- for the given disk or partition.
getDiskInfo :: String -> IO [Int]
getDiskInfo = getParsedInfo "/proc/diskstats" parse
parse :: String -> [(String, [Int])]
parse = mapMaybe (tuplize . drop 2 . words) . lines
tuplize :: [String] -> Maybe (String, [Int])
tuplize s = do
device <- headMay s
used <- s `atMay` 3
capacity <- s `atMay` 7
return (device, [readDef (-1) used, readDef (-1) capacity])
taffybar-3.0.0/src/System/Taffybar/Information/XDG/ 0000755 0000000 0000000 00000000000 13317725701 020224 5 ustar 00 0000000 0000000 taffybar-3.0.0/src/System/Taffybar/Information/XDG/DesktopEntry.hs 0000644 0000000 0000000 00000017131 13317725701 023216 0 ustar 00 0000000 0000000 -----------------------------------------------------------------------------
-- |
-- Module : System.Taffybar.Information.XDG.DesktopEntry
-- 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 Entry
-- specification", see
-- https://specifications.freedesktop.org/desktop-entry-spec/desktop-entry-spec-1.2.html.
-----------------------------------------------------------------------------
module System.Taffybar.Information.XDG.DesktopEntry
( DesktopEntry(..)
, deCommand
, deComment
, deHasCategory
, deIcon
, deName
, deNoDisplay
, deNotShowIn
, deOnlyShowIn
, existingDirs
, getDefaultConfigHome
, getDefaultDataHome
, getDirectoryEntriesDefault
, getDirectoryEntry
, getDirectoryEntryDefault
, getXDGDataDirs
, listDesktopEntries
) where
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.Except
import Data.Char
import qualified Data.ConfigFile as CF
import Data.List
import Data.Maybe
import System.Directory
import System.Environment
import System.FilePath.Posix
import System.Log.Logger
import System.Posix.Files
import Text.Printf
data DesktopEntryType = Application | Link | Directory
deriving (Read, Show, Eq)
existingDirs :: [FilePath] -> IO [FilePath]
existingDirs dirs = do
exs <- mapM fileExist dirs
let exDirs = nub $ map fst $ filter snd $ zip dirs exs
mapM_ (putStrLn . ("Directory does not exist: " ++)) $ dirs \\ exDirs
return exDirs
getDefaultConfigHome :: IO FilePath
getDefaultConfigHome = do
h <- getHomeDirectory
return $ h ".config"
getDefaultDataHome :: IO FilePath
getDefaultDataHome = do
h <- getHomeDirectory
return $ h ".local" "share"
-- XXX: We really ought to use
-- https://hackage.haskell.org/package/directory-1.3.2.2/docs/System-Directory.html#v:getXdgDirectory
getXDGDataDirs :: IO [FilePath]
getXDGDataDirs = do
dataHome <- lookupEnv "XDG_DATA_HOME" >>= maybe getDefaultDataHome return
dataDirs <- map normalise . splitSearchPath . fromMaybe "" <$>
lookupEnv "XDG_DATA_DIRS"
nubBy equalFilePath <$>
existingDirs ( dataHome:dataDirs
++ ["/usr/local/share", "/usr/share"]
)
-- | Desktop Entry. All attributes (key-value-pairs) are stored in an
-- association list.
data DesktopEntry = DesktopEntry
{ deType :: DesktopEntryType
, deFilename :: FilePath -- ^ unqualified filename, e.g. "taffybar.desktop"
, deAttributes :: [(String, String)] -- ^ Key-value pairs
} deriving (Read, Show, Eq)
-- | Determine whether the Category attribute of a desktop entry contains a
-- given value.
deHasCategory
:: DesktopEntry -- ^ desktop entry
-> String -- ^ category to be checked
-> Bool
deHasCategory de cat =
maybe False ((cat `elem`) . splitAtSemicolon) $
lookup "Categories" (deAttributes de)
splitAtSemicolon :: String -> [String]
splitAtSemicolon = lines . map (\c -> if c == ';' then '\n' else c)
-- | Return the proper name of the desktop entry, depending on the list of
-- preferred languages.
deName
:: [String] -- ^ Preferred languages
-> DesktopEntry
-> String
deName langs de = fromMaybe (deFilename de) $ deLocalisedAtt langs de "Name"
-- | Return the categories in which the entry shall be shown
deOnlyShowIn :: DesktopEntry -> [String]
deOnlyShowIn = maybe [] splitAtSemicolon . deAtt "OnlyShowIn"
-- | Return the categories in which the entry shall not be shown
deNotShowIn :: DesktopEntry -> [String]
deNotShowIn = maybe [] splitAtSemicolon . deAtt "NotShowIn"
-- | Return the value of the given attribute key
deAtt :: String -> DesktopEntry -> Maybe String
deAtt att = lookup att . deAttributes
-- | Return the Icon attribute
deIcon :: DesktopEntry -> Maybe String
deIcon = deAtt "Icon"
-- | Return True if the entry must not be displayed
deNoDisplay :: DesktopEntry -> Bool
deNoDisplay de = maybe False (("true" ==) . map toLower) $ deAtt "NoDisplay" de
deLocalisedAtt
:: [String] -- ^ Preferred languages
-> DesktopEntry
-> String
-> Maybe String
deLocalisedAtt langs de att =
let localeMatches =
mapMaybe (\l -> lookup (att ++ "[" ++ l ++ "]") (deAttributes de)) langs
in if null localeMatches
then lookup att $ deAttributes de
else Just $ head localeMatches
-- | Return the proper comment of the desktop entry, depending on the list of
-- preferred languages.
deComment :: [String] -- ^ Preferred languages
-> DesktopEntry
-> Maybe String
deComment langs de = deLocalisedAtt langs de "Comment"
-- | Return the command defined by the given desktop entry.
-- TODO: should check the dbus thing.
-- TODO: are there "field codes", i.e. % things, that
deCommand :: DesktopEntry -> Maybe String
deCommand de =
reverse . dropWhile (== ' ') . reverse . takeWhile (/= '%') <$>
lookup "Exec" (deAttributes de)
-- | Return a list of all desktop entries in the given directory.
listDesktopEntries
:: String -- ^ The extension to use in the search
-> FilePath -- ^ The filepath at which to search
-> IO [DesktopEntry]
listDesktopEntries extension dir = do
let normalizedDir = normalise dir
ex <- doesDirectoryExist normalizedDir
if ex
then do
files <-
map (normalizedDir ) . filter (\v -> v /= "." && v /= "..") <$>
getDirectoryContents dir
entries <-
(nub . catMaybes) <$>
mapM readDesktopEntry (filter (extension `isSuffixOf`) files)
subDirs <- filterM doesDirectoryExist files
subEntries <- concat <$> mapM (listDesktopEntries extension) subDirs
return $ entries ++ subEntries
else return []
-- XXX: This function doesn't recurse, but `listDesktopEntries` does. Why?
-- Shouldn't they really share logic...
-- | Retrieve a desktop entry with a specific name.
getDirectoryEntry :: [FilePath] -> String -> IO (Maybe DesktopEntry)
getDirectoryEntry dirs name = do
liftIO $ logM "System.Taffybar.Information.XDG.DesktopEntry" DEBUG $
printf "Searching %s for %s" (show dirs) name
exFiles <- filterM doesFileExist $ map (( name) . normalise) dirs
if null exFiles
then return Nothing
else readDesktopEntry $ head exFiles
getDirectoryEntryDefault :: String -> IO (Maybe DesktopEntry)
getDirectoryEntryDefault entry =
fmap ( "applications") <$> getXDGDataDirs >>=
flip getDirectoryEntry (printf "%s.desktop" entry)
getDirectoryEntriesDefault :: IO [DesktopEntry]
getDirectoryEntriesDefault =
fmap ( "applications") <$> getXDGDataDirs >>= foldM addDirectories []
where addDirectories soFar directory =
(soFar ++) <$> listDesktopEntries "desktop" directory
-- | Main section of a desktop entry file.
sectionMain :: String
sectionMain = "Desktop Entry"
-- | Read a desktop entry from a file.
readDesktopEntry :: FilePath -> IO (Maybe DesktopEntry)
readDesktopEntry fp = do
ex <- doesFileExist fp
if ex
then doReadDesktopEntry fp
else do
putStrLn $ "File does not exist: '" ++ fp ++ "'"
return Nothing
where
doReadDesktopEntry :: FilePath -> IO (Maybe DesktopEntry)
doReadDesktopEntry f = do
eResult <-
runExceptT $ do
cp <- join $ liftIO $ CF.readfile CF.emptyCP f
CF.items cp sectionMain
case eResult of
Left _ -> return Nothing
Right r ->
return $
Just
DesktopEntry
{ deType = maybe Application read (lookup "Type" r)
, deFilename = f
, deAttributes = r
}
taffybar-3.0.0/src/System/Taffybar/Information/XDG/Protocol.hs 0000644 0000000 0000000 00000023705 13317725701 022370 0 ustar 00 0000000 0000000 -----------------------------------------------------------------------------
-- |
-- Module : System.Taffybar.Information.XDG.Protocol
-- Copyright : 2017 Ulf Jasper
-- License : BSD3-style (see LICENSE)
--
-- Maintainer : Ulf Jasper
-- Stability : unstable
-- Portability : unportable
--
-- Implementation of version 1.1 of the XDG "Desktop Menu
-- Specification", see
-- https://specifications.freedesktop.org/menu-spec/menu-spec-1.1.html
---- specification, see
-- See also 'MenuWidget'.
--
-----------------------------------------------------------------------------
module System.Taffybar.Information.XDG.Protocol
( XDGMenu(..)
, DesktopEntryCondition(..)
, readXDGMenu
, matchesCondition
, getXDGDesktop
, getDirectoryDirs
, getApplicationEntries
, getPreferredLanguages
) where
import Control.Applicative
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.FilePath.Posix
import System.Taffybar.Information.XDG.DesktopEntry
import System.Taffybar.Util
import Text.XML.Light
import Text.XML.Light.Helpers
-- Environment Variables
-- | Produce a list of config locations to search, starting with
-- XDG_CONFIG_HOME (or $HOME/.config) and XDG_CONFIG_DIRS, with
-- fallback to /etc/xdg
getXDGConfigDirs :: IO [String]
getXDGConfigDirs = do
mXdgConfigHome <- fromMaybe "" <$>
lookupEnv "XDG_CONFIG_HOME"
xdgConfigHome <- if null mXdgConfigHome
then getDefaultConfigHome
else return mXdgConfigHome
xdgConfigDirs <- maybe [] splitSearchPath <$>
lookupEnv "XDG_CONFIG_DIRS"
let xdgDirs = if null xdgConfigDirs
then ["/etc/xdg/"]
else xdgConfigDirs
existingDirs $ map normalise $ xdgConfigHome : xdgDirs
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 <- getXDGConfigDirs
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
existingDirs $ map ( "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
putStrLn $ "Reading " ++ filename
contents <- readFile filename
langs <- getPreferredLanguages
runMaybeT $ do
m <- MaybeT $ return $ parseXMLDoc contents >>= parseMenu
des <- lift $ getApplicationEntries langs m
return (m, des))
(do
putStrLn $ "Error: menu file '" ++ filename ++ "' does not exist!"
return Nothing)
taffybar-3.0.0/src/System/Taffybar/Support/ 0000755 0000000 0000000 00000000000 13317725701 016771 5 ustar 00 0000000 0000000 taffybar-3.0.0/src/System/Taffybar/Support/PagerHints.hs 0000644 0000000 0000000 00000007624 13317725701 021402 0 ustar 00 0000000 0000000 -----------------------------------------------------------------------------
-- |
-- Module : System.Taffybar.Hooks.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.Hooks.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.0.0/src/System/Taffybar/DBus/ 0000755 0000000 0000000 00000000000 13317725701 016152 5 ustar 00 0000000 0000000 taffybar-3.0.0/src/System/Taffybar/DBus/Toggle.hs 0000644 0000000 0000000 00000014104 13317725701 017727 0 ustar 00 0000000 0000000 {-# LANGUAGE OverloadedStrings #-}
-----------------------------------------------------------------------------
-- |
-- Module : System.Taffybar.DBus.Toggle
-- Copyright : (c) Ivan A. Malison
-- License : BSD3-style (see LICENSE)
--
-- Maintainer : Ivan A. Malison
-- Stability : unstable
-- Portability : unportable
--
-- This module provides a dbus interface that allows users to toggle the display
-- of taffybar on each monitor while it is running.
-----------------------------------------------------------------------------
module System.Taffybar.DBus.Toggle ( handleDBusToggles ) where
import Control.Applicative
import qualified Control.Concurrent.MVar as MV
import Control.Monad
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 Graphics.UI.GIGtkStrut
import Paths_taffybar ( getDataDir )
import Prelude
import System.Directory
import System.FilePath.Posix
import System.Log.Logger
import System.Taffybar.Context hiding (logIO, logT)
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 :: MonadTrans t => System.Log.Logger.Priority -> String -> t IO ()
logT p m = lift $ logIO p m
getActiveMonitorNumber :: MaybeT IO Int
getActiveMonitorNumber = do
display <- MaybeT Gdk.displayGetDefault
seat <- lift $ Gdk.displayGetDefaultSeat display
device <- MaybeT $ Gdk.seatGetPointer seat
lift $ do
(_, x, y) <- Gdk.deviceGetPosition device
Gdk.displayGetMonitorAtPoint display x y >>= getMonitorNumber
getMonitorNumber :: Gdk.Monitor -> IO Int
getMonitorNumber monitor = do
display <- Gdk.monitorGetDisplay monitor
monitorCount <- Gdk.displayGetNMonitors display
monitors <- mapM (Gdk.displayGetMonitor display) [0..(monitorCount-1)]
monitorGeometry <- Gdk.getMonitorGeometry monitor
let equalsMonitor (Just other, _) =
do
otherGeometry <- Gdk.getMonitorGeometry other
case (otherGeometry, monitorGeometry) of
(Nothing, Nothing) -> return True
(Just g1, Just g2) -> Gdk.rectangleEqual g1 g2
_ -> return False
equalsMonitor _ = return False
snd . fromMaybe (Nothing, 0) . listToMaybe <$>
filterM equalsMonitor (zip monitors [0..])
taffybarTogglePath :: ObjectPath
taffybarTogglePath = "/taffybar/toggle"
taffybarToggleInterface :: InterfaceName
taffybarToggleInterface = "taffybar.toggle"
toggleStateFile :: IO FilePath
toggleStateFile = ( "toggleState.hs") <$> getDataDir
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
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" $ show numToEnabled
logIO DEBUG $ printf "Toggle state after: %s" $ show result
flip writeFile (show result) =<< toggleStateFile
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
]
}
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.0.0/src/System/Taffybar/DBus/Client/ 0000755 0000000 0000000 00000000000 13317725701 017370 5 ustar 00 0000000 0000000 taffybar-3.0.0/src/System/Taffybar/DBus/Client/UPowerDevice.hs 0000644 0000000 0000000 00000000677 13317725701 022277 0 ustar 00 0000000 0000000 {-# LANGUAGE TemplateHaskell #-}
module System.Taffybar.DBus.Client.UPowerDevice where
import System.FilePath
import System.Taffybar.DBus.Client.Params
import System.Taffybar.DBus.Client.Util
generateClientFromFile
defaultRecordGenerationParams
{ recordName = Just "BatteryInfo"
, recordPrefix = "battery"
, recordTypeForName = batteryTypeForName
}
uPowerGenerationParams
False $ "dbus-xml" "org.freedesktop.UPower.Device.xml"
taffybar-3.0.0/src/System/Taffybar/DBus/Client/MPRIS2.hs 0000644 0000000 0000000 00000000762 13317725701 020705 0 ustar 00 0000000 0000000 {-# LANGUAGE TemplateHaskell #-}
module System.Taffybar.DBus.Client.MPRIS2 where
import System.Taffybar.DBus.Client.Util
import System.FilePath
import System.Taffybar.DBus.Client.Params
generateClientFromFile defaultRecordGenerationParams playerGenerationParams False $
"dbus-xml" "org.mpris.MediaPlayer2.xml"
generateClientFromFile defaultRecordGenerationParams playerGenerationParams False $
"dbus-xml" "org.mpris.MediaPlayer2.Player.xml"
taffybar-3.0.0/src/System/Taffybar/DBus/Client/Util.hs 0000644 0000000 0000000 00000006743 13317725701 020653 0 ustar 00 0000000 0000000 {-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
module System.Taffybar.DBus.Client.Util where
import Control.Applicative
import DBus.Generation
import qualified DBus.Internal.Types as T
import qualified DBus.Introspection as I
import qualified Data.Char as Char
import Data.Coerce
import Data.Maybe
import Language.Haskell.TH
import StatusNotifier.Util (getIntrospectionObjectFromFile)
#if __GLASGOW_HASKELL__ >= 802
deriveShowAndEQ :: [DerivClause]
deriveShowAndEQ =
[DerivClause Nothing [ConT ''Eq, ConT ''Show]]
#endif
buildDataFromNameTypePairs :: Name -> [(Name, Type)] -> Dec
buildDataFromNameTypePairs name pairs =
DataD [] name [] Nothing [RecC name (map mkVarBangType pairs)]
#if __GLASGOW_HASKELL__ >= 802
deriveShowAndEQ
#else
[]
#endif
where mkVarBangType (fieldName, fieldType) =
(fieldName, Bang NoSourceUnpackedness NoSourceStrictness, fieldType)
standaloneDeriveEqShow :: Name -> [Dec]
#if __GLASGOW_HASKELL__ < 802
standaloneDeriveEqShow name =
[ StandaloneDerivD [] (ConT ''Eq `AppT` ConT name)
, StandaloneDerivD [] (ConT ''Show `AppT` ConT name)
]
#else
standaloneDeriveEqShow _ = []
#endif
type GetTypeForName = String -> T.Type -> Maybe Type
data RecordGenerationParams = RecordGenerationParams
{ recordName :: Maybe String
, recordPrefix :: String
, recordTypeForName :: GetTypeForName
}
defaultRecordGenerationParams :: RecordGenerationParams
defaultRecordGenerationParams = RecordGenerationParams
{ recordName = Nothing
, recordPrefix = "_"
, recordTypeForName = const $ const Nothing
}
generateGetAllRecord
:: RecordGenerationParams
-> GenerationParams
-> I.Interface
-> Q [Dec]
generateGetAllRecord
RecordGenerationParams
{ recordName = recordNameString
, recordPrefix = prefix
, recordTypeForName = getTypeForName
}
GenerationParams { getTHType = getArgType }
I.Interface { I.interfaceName = interfaceName
, I.interfaceProperties = properties
} = do
let theRecordName =
maybe (mkName $ map Char.toUpper $ filter Char.isLetter $ coerce interfaceName)
mkName recordNameString
let getPairFromProperty I.Property
{ I.propertyName = propName
, I.propertyType = propType
} =
( mkName $ prefix ++ propName
, fromMaybe (getArgType propType) $ getTypeForName propName propType
)
getAllRecord =
buildDataFromNameTypePairs
theRecordName $ map getPairFromProperty properties
return $ getAllRecord:standaloneDeriveEqShow theRecordName
generateClientFromFile :: RecordGenerationParams -> GenerationParams -> Bool -> FilePath -> Q [Dec]
generateClientFromFile recordGenerationParams params useObjectPath filepath = do
object <- getIntrospectionObjectFromFile filepath "/"
let interface = head $ I.objectInterfaces object
actualObjectPath = I.objectPath object
realParams =
if useObjectPath
then params {genObjectPath = Just actualObjectPath}
else params
(<++>) = liftA2 (++)
generateGetAllRecord recordGenerationParams params interface <++>
generateClient realParams interface <++>
generateSignalsFromInterface realParams interface
taffybar-3.0.0/src/System/Taffybar/DBus/Client/Params.hs 0000644 0000000 0000000 00000003645 13317725701 021157 0 ustar 00 0000000 0000000 {-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE OverloadedStrings #-}
module System.Taffybar.DBus.Client.Params where
import DBus
import DBus.Generation
import Language.Haskell.TH
import System.Taffybar.DBus.Client.Util
playerGenerationParams :: GenerationParams
playerGenerationParams = defaultGenerationParams
{ genTakeSignalErrorHandler = True
, genObjectPath = Just "/org/mpris/MediaPlayer2"
}
-- | The base object path for the UPower interface
uPowerBaseObjectPath :: ObjectPath
uPowerBaseObjectPath = "/org/freedesktop/UPower"
-- | The name of the power daemon bus
uPowerBusName :: BusName
uPowerBusName = "org.freedesktop.UPower"
uPowerDeviceInterfaceName :: InterfaceName
uPowerDeviceInterfaceName = "org.freedesktop.UPower.Device"
uPowerGenerationParams :: GenerationParams
uPowerGenerationParams = defaultGenerationParams
{ genTakeSignalErrorHandler = True
, genBusName = Just uPowerBusName
}
data BatteryType
= BatteryTypeUnknown
| BatteryTypeLinePower
| BatteryTypeBatteryType
| BatteryTypeUps
| BatteryTypeMonitor
| BatteryTypeMouse
| BatteryTypeKeyboard
| BatteryTypePda
| BatteryTypePhone
deriving (Show, Ord, Eq, Enum)
data BatteryState
= BatteryStateUnknown
| BatteryStateCharging
| BatteryStateDischarging
| BatteryStateEmpty
| BatteryStateFullyCharged
| BatteryStatePendingCharge
| BatteryStatePendingDischarge
deriving (Show, Ord, Eq, Enum)
data BatteryTechnology
= BatteryTechnologyUnknown
| BatteryTechnologyLithiumIon
| BatteryTechnologyLithiumPolymer
| BatteryTechnologyLithiumIronPhosphate
| BatteryTechnologyLeadAcid
| BatteryTechnologyNickelCadmium
| BatteryTechnologyNickelMetalHydride
deriving (Show, Ord, Eq, Enum)
batteryTypeForName :: GetTypeForName
batteryTypeForName name = const $
case name of
"Type" -> yes ''BatteryType
"State" -> yes ''BatteryState
"Technology" -> yes ''BatteryTechnology
_ -> Nothing
where yes = Just . ConT
taffybar-3.0.0/src/System/Taffybar/DBus/Client/UPower.hs 0000644 0000000 0000000 00000001003 13317725701 021137 0 ustar 00 0000000 0000000 {-# LANGUAGE TemplateHaskell #-}
module System.Taffybar.DBus.Client.UPower where
import DBus.Generation
import System.FilePath
import System.Taffybar.DBus.Client.Params
import System.Taffybar.DBus.Client.Util
generateClientFromFile
defaultRecordGenerationParams { recordName = Just "UPowerInfo"
, recordPrefix = "upi"
}
uPowerGenerationParams { genObjectPath = Just uPowerBaseObjectPath }
False $
"dbus-xml" "org.freedesktop.UPower.xml"
taffybar-3.0.0/src/System/Taffybar/Widget/ 0000755 0000000 0000000 00000000000 13317725701 016540 5 ustar 00 0000000 0000000 taffybar-3.0.0/src/System/Taffybar/Widget/SimpleClock.hs 0000644 0000000 0000000 00000010120 13317725701 021273 0 ustar 00 0000000 0000000 {-# LANGUAGE CPP #-}
{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE OverloadedStrings #-}
-- | 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.
module System.Taffybar.Widget.SimpleClock
( textClockNew
, textClockNewWith
, defaultClockConfig
, ClockConfig(..)
) where
import Control.Monad.IO.Class
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 GI.Gtk
import qualified GI.Gdk as D
import System.Taffybar.Widget.Generic.PollingLabel
import System.Taffybar.Widget.Util
import qualified Data.Text as T
makeCalendar :: IO TimeZone -> IO Window
makeCalendar tzfn = do
container <- windowNew WindowTypeToplevel
cal <- calendarNew
containerAdd container cal
-- update the date on show
_ <- onWidgetShow container $ resetCalendarDate cal tzfn
-- prevent calendar from being destroyed, it can be only hidden:
_ <- 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
-- (http://developer.gnome.org/pango/stable/PangoMarkupFormat.html).
textClockNew :: MonadIO m => Maybe L.TimeLocale -> String -> Double -> m GI.Gtk.Widget
textClockNew userLocale =
textClockNewWith cfg
where
cfg = defaultClockConfig { clockTimeLocale = userLocale }
data ClockConfig = ClockConfig { clockTimeZone :: Maybe TimeZone
, clockTimeLocale :: Maybe L.TimeLocale
}
deriving (Eq, Ord, Show)
-- | A clock configuration that defaults to the current locale
defaultClockConfig :: ClockConfig
defaultClockConfig = ClockConfig Nothing Nothing
data TimeInfo = TimeInfo { getTZ :: IO TimeZone
, getLocale :: IO L.TimeLocale
}
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_tzset
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 -> String -> Double -> m Widget
textClockNewWith cfg fmt updateSeconds = liftIO $ do
let ti = TimeInfo { getTZ = maybe systemGetTZ return userZone
, getLocale = maybe (return L.defaultTimeLocale) return userLocale
}
l <- pollingLabelNew "" updateSeconds (getCurrentTime' ti fmt)
ebox <- eventBoxNew
containerAdd ebox l
eventBoxSetVisibleWindow ebox False
cal <- makeCalendar $ getTZ ti
_ <- onWidgetButtonPressEvent ebox $ onClick [D.EventTypeButtonPress] (toggleCalendar l cal)
widgetShowAll ebox
toWidget ebox
where
userZone = clockTimeZone cfg
userLocale = clockTimeLocale cfg
-- alternate getCurrentTime that takes a specific TZ
getCurrentTime' :: TimeInfo -> String -> IO T.Text
getCurrentTime' ti f = do
l <- getLocale ti
z <- getTZ ti
t <- Clock.getCurrentTime
return $ T.pack $ formatTime l f $ utcToZonedTime z t
taffybar-3.0.0/src/System/Taffybar/Widget/CPUMonitor.hs 0000644 0000000 0000000 00000003161 13317725701 021074 0 ustar 00 0000000 0000000 --------------------------------------------------------------------------------
-- |
-- Module : System.Taffybar.Widget.CPUMonitor
-- Copyright : (c) José A. Romero L.
-- License : BSD3-style (see LICENSE)
--
-- Maintainer : José A. Romero L.
-- Stability : unstable
-- Portability : unportable
--
-- Simple CPU monitor that uses a PollingGraph to visualize variations in the
-- user and system CPU times in one selected core, or in all cores available.
--
--------------------------------------------------------------------------------
module System.Taffybar.Widget.CPUMonitor where
import Control.Monad.IO.Class
import Data.IORef
import qualified GI.Gtk
import System.Taffybar.Information.CPU2 (getCPUInfo)
import System.Taffybar.Information.StreamInfo (getAccLoad)
import System.Taffybar.Widget.Generic.PollingGraph
-- | Creates a new CPU monitor. This is a PollingGraph fed by regular calls to
-- getCPUInfo, associated to an IORef used to remember the values yielded by the
-- last call to this function.
cpuMonitorNew
:: MonadIO m
=> GraphConfig -- ^ Configuration data for the Graph.
-> Double -- ^ Polling period (in seconds).
-> String -- ^ Name of the core to watch (e.g. \"cpu\", \"cpu0\").
-> m GI.Gtk.Widget
cpuMonitorNew cfg interval cpu = liftIO $ do
info <- getCPUInfo cpu
sample <- newIORef info
pollingGraphNew cfg interval $ probe sample cpu
probe :: IORef [Int] -> String -> IO [Double]
probe sample cpuName = do
load <- getAccLoad sample $ getCPUInfo cpuName
case load of
l0:l1:l2:_ -> return [ l0 + l1, l2 ] -- user, system
_ -> return []
taffybar-3.0.0/src/System/Taffybar/Widget/SNITray.hs 0000644 0000000 0000000 00000004021 13317725701 020362 0 ustar 00 0000000 0000000 {-# LANGUAGE OverloadedStrings #-}
-----------------------------------------------------------------------------
-- |
-- Module : System.Taffybar.Widget.SNITray
-- Copyright : (c) Ivan A. Malison
-- License : BSD3-style (see LICENSE)
--
-- Maintainer : Ivan A. Malison
-- Stability : unstable
-- Portability : unportable
-----------------------------------------------------------------------------
module System.Taffybar.Widget.SNITray where
import Control.Monad.Trans.Class
import Control.Monad.Trans.Reader
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
}
_ <- 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.0.0/src/System/Taffybar/Widget/Battery.hs 0000644 0000000 0000000 00000011425 13317725701 020511 0 ustar 00 0000000 0000000 {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
-----------------------------------------------------------------------------
-- |
-- Module : System.Taffybar.Widget.Battery
-- Copyright : (c) Ivan A. Malison
-- License : BSD3-style (see LICENSE)
--
-- Maintainer : Ivan A. Malison
-- Stability : unstable
-- Portability : unportable
--
-- This module provides battery widgets 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
defaultTheme <- iconThemeGetDefault
let getCurrentBatteryIconNameString =
T.pack . batteryIconName <$> runReaderT getDisplayBatteryInfo ctx
setIconForSize size = do
name <- getCurrentBatteryIconNameString
iconThemeLoadIcon defaultTheme name size themeLoadFlags >>=
traverse (scalePixbufToSize size OrientationHorizontal)
updateImage <- autoSizeImage image setIconForSize OrientationHorizontal
toWidget =<< channelWidgetNew image chan (const $ postGUIASync updateImage)
taffybar-3.0.0/src/System/Taffybar/Widget/NetworkGraph.hs 0000644 0000000 0000000 00000001642 13317725701 021512 0 ustar 00 0000000 0000000 module 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.0.0/src/System/Taffybar/Widget/MPRIS2.hs 0000644 0000000 0000000 00000013543 13317725701 020056 0 ustar 00 0000000 0000000 {-# 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
-- (https://specifications.freedesktop.org/mpris-spec/latest/).
-----------------------------------------------------------------------------
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.Taffybar.Information.XDG.DesktopEntry
import System.Taffybar.Util
import System.Taffybar.Widget.Generic.AutoSizeImage
import System.Taffybar.Widget.Util
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 logErrorAndLoadDefault size err =
mprisLog WARNING "Failed to get MPRIS icon: %s" err >>
mprisLog WARNING "MPRIS failure for: %s" busName >>
loadIcon size "play.svg"
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 (fromIntegral $ T.length formattedText)
where formattedText = T.pack $ printf
"%s - %s"
(truncateString artistMax $ intercalate "," artists)
(truncateString songMax title)
taffybar-3.0.0/src/System/Taffybar/Widget/Layout.hs 0000644 0000000 0000000 00000007244 13317725701 020360 0 ustar 00 0000000 0000000 -----------------------------------------------------------------------------
-- |
-- 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
-- $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)
-- 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 <- subscribeToEvents [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.0.0/src/System/Taffybar/Widget/Decorators.hs 0000644 0000000 0000000 00000002247 13317725701 021206 0 ustar 00 0000000 0000000 {-# 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.hBoxNew False 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.hBoxNew False 0
Gtk.containerAdd contents widget
_ <- widgetSetClassGI contents "contents"
Gtk.widgetShowAll contents
Gtk.toWidget contents >>= buildPadBox
taffybar-3.0.0/src/System/Taffybar/Widget/Util.hs 0000644 0000000 0000000 00000015136 13317725701 020017 0 ustar 00 0000000 0000000 -----------------------------------------------------------------------------
-- |
-- Module : System.Taffybar.Widget.Util
-- Copyright : (c) José A. Romero L.
-- License : BSD3-style (see LICENSE)
--
-- Maintainer : José A. Romero L.
-- Stability : unstable
-- Portability : unportable
--
-- Utility functions to facilitate building GTK interfaces.
--
-----------------------------------------------------------------------------
module System.Taffybar.Widget.Util where
import Control.Concurrent ( forkIO )
import Control.Monad ( forever, void )
import Control.Monad.IO.Class
import Control.Monad.Trans.Maybe
import Data.Functor ( ($>) )
import Data.Int
import qualified Data.Text as T
import qualified GI.GdkPixbuf.Objects.Pixbuf as GI
import qualified GI.GdkPixbuf.Objects.Pixbuf as PB
import GI.Gtk as Gtk
import qualified GI.Gdk as D
import System.Directory
import System.FilePath.Posix
import System.Taffybar.Information.XDG.DesktopEntry
import System.Taffybar.Util
import Text.Printf
import qualified Graphics.Rendering.Cairo as C
import qualified GI.Cairo
import Control.Monad.Trans.Reader (runReaderT)
import Graphics.Rendering.Cairo.Internal (Render(runRender))
import Foreign.Ptr (castPtr)
import Graphics.Rendering.Cairo.Types (Cairo(Cairo))
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 (undefined :: 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
(_, y') <- widgetGetSizeRequest widget
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 entry = runMaybeT $ do
iconName <- MaybeT $ return $ deIcon entry
let iconNameText = T.pack iconName
MaybeT $ do
iconTheme <- Gtk.iconThemeGetDefault
hasIcon <- Gtk.iconThemeHasIcon iconTheme iconNameText
logPrintFDebug "System.Taffybar.Widget.Util" "Entry: %s" entry
logPrintFDebug "System.Taffybar.Widget.Util" "Icon present: %s" hasIcon
if hasIcon
then
Gtk.iconThemeLoadIcon iconTheme iconNameText size themeLoadFlags
else do
exists <- doesFileExist iconName
if isAbsolute iconName && exists
then Just <$> GI.pixbufNewFromFile iconName
else return Nothing
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
renderWithContext :: GI.Cairo.Context -> C.Render () -> IO ()
renderWithContext ct r = GI.Cairo.withManagedPtr ct $ \p ->
runReaderT (runRender r) (Cairo (castPtr p))
taffybar-3.0.0/src/System/Taffybar/Widget/Windows.hs 0000644 0000000 0000000 00000010061 13317725701 020524 0 ustar 00 0000000 0000000 {-# LANGUAGE OverloadedStrings #-}
-----------------------------------------------------------------------------
-- |
-- Module : System.Taffybar.Widget.Windows
-- Copyright : (c) Ivan Malison
-- License : BSD3-style (see LICENSE)
--
-- Maintainer : Ivan Malison
-- Stability : unstable
-- Portability : unportable
--
-- Menu widget that shows the title of the currently focused window and that,
-- when clicked, displays a menu from which the user may select a window to
-- which to switch the focus.
-----------------------------------------------------------------------------
module System.Taffybar.Widget.Windows (
-- * Usage
-- $usage
windowsNew
, WindowsConfig(..)
, defaultWindowsConfig
, truncatedGetActiveLabel
, truncatedGetMenuLabel
) 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
-- $usage
--
-- The window switcher widget requires that the EwmhDesktops hook from the
-- XMonadContrib project be installed in your @xmonad.hs@ file:
--
-- > import XMonad.Hooks.EwmhDesktops (ewmh)
-- > main = do
-- > xmonad $ ewmh $ defaultConfig
-- > ...
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)
markupEscapeText (T.pack windowString) $ fromIntegral $ length windowString
defaultGetActiveLabel :: TaffyIO T.Text
defaultGetActiveLabel = fromMaybe "" <$>
(runX11Def Nothing getActiveWindow >>= traverse defaultGetMenuLabel)
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 = defaultGetMenuLabel
, getActiveLabel = defaultGetActiveLabel
}
-- | 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 <- subscribeToEvents ["_NET_ACTIVE_WINDOW"] 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.0.0/src/System/Taffybar/Widget/DiskIOMonitor.hs 0000644 0000000 0000000 00000003056 13317725701 021572 0 ustar 00 0000000 0000000 --------------------------------------------------------------------------------
-- |
-- Module : System.Taffybar.Widget.DiskIOMonitor
-- Copyright : (c) José A. Romero L.
-- License : BSD3-style (see LICENSE)
--
-- Maintainer : José A. Romero L.
-- Stability : unstable
-- Portability : unportable
--
-- Simple Disk IO monitor that uses a PollingGraph to visualize the speed of
-- read/write operations in one selected disk or partition.
--
--------------------------------------------------------------------------------
module System.Taffybar.Widget.DiskIOMonitor ( dioMonitorNew ) where
import Control.Monad.IO.Class
import qualified GI.Gtk
import System.Taffybar.Information.DiskIO ( getDiskTransfer )
import System.Taffybar.Widget.Generic.PollingGraph ( GraphConfig, pollingGraphNew )
-- | Creates a new disk IO monitor widget. This is a 'PollingGraph' fed by
-- regular calls to 'getDiskTransfer'. The results of calling this function
-- are normalized to the maximum value of the obtained probe (either read or
-- write transfer).
dioMonitorNew
:: MonadIO m
=> GraphConfig -- ^ Configuration data for the Graph.
-> Double -- ^ Polling period (in seconds).
-> String -- ^ Name of the disk or partition to watch (e.g. \"sda\", \"sdb1\").
-> m GI.Gtk.Widget
dioMonitorNew cfg pollSeconds =
pollingGraphNew cfg pollSeconds . probeDisk
probeDisk :: String -> IO [Double]
probeDisk disk = do
transfer <- getDiskTransfer disk
let top = foldr max 1.0 transfer
return $ map (/top) transfer
taffybar-3.0.0/src/System/Taffybar/Widget/Weather.hs 0000644 0000000 0000000 00000025162 13317725701 020501 0 ustar 00 0000000 0000000 {-# LANGUAGE OverloadedStrings #-}
-- | This module defines a simple textual weather widget that polls
-- NOAA for weather data. To find your weather station, you can use
--
--
--
-- 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 GI.Gtk
import GI.GLib(markupEscapeText)
import qualified Network.Browser as Browser
import Network.HTTP
import Network.URI
import Text.Parsec
import Text.Printf
import Text.StringTemplate
import qualified Data.Text as T
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. Taken from Real World
-- Haskell.
downloadURL :: Maybe String -> String -> IO (Either String String)
downloadURL mProxy url = do
(_, r) <- Browser.browse $ do
case mProxy of
Just proxy -> Browser.setProxy $ Browser.Proxy proxy Nothing
Nothing -> return ()
Browser.setAllowRedirects True
Browser.request request
case rspCode r of
(2,_,_) -> return $ Right (rspBody r)
_ -> return $ Left (show r)
where
request = Request { rqURI = uri
, rqMethod = GET
, rqHeaders = []
, rqBody = ""
}
Just uri = parseURI url
getWeather :: Maybe String -> String -> IO (Either String WeatherInfo)
getWeather mProxy url = do
dat <- downloadURL mProxy url
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 (fromIntegral $ T.length rawLabel)
tooltip <- markupEscapeText rawTooltip (fromIntegral $ T.length rawTooltip)
return (lbl, Just tooltip)
WeatherFormatter f -> do
let rawLabel = T.pack $ f wi
lbl <- markupEscapeText rawLabel (fromIntegral $ T.length rawLabel)
return (lbl, Just lbl)
Left err -> do
putStrLn err
return ("N/A", Nothing)
-- | The NOAA URL to get data from
baseUrl :: String
baseUrl = "http://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
let url = printf "%s/%s.TXT" baseUrl (weatherStation cfg)
getter = getWeather (weatherProxy cfg) 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 "N/A" (delayMinutes * 60)
(getCurrentWeather getter labelTpl' tooltipTpl' formatter)
GI.Gtk.widgetShowAll l
return l
taffybar-3.0.0/src/System/Taffybar/Widget/FSMonitor.hs 0000644 0000000 0000000 00000003250 13317725701 020754 0 ustar 00 0000000 0000000 {-# LANGUAGE OverloadedStrings #-}
-----------------------------------------------------------------------------
-- |
-- Module : System.Taffybar.Widget.FSMonitor
-- Copyright : (c) José A. Romero L.
-- License : BSD3-style (see LICENSE)
--
-- Maintainer : José A. Romero L.
-- Stability : unstable
-- Portability : unportable
--
-- Simple text widget that monitors the current usage of selected disk
-- partitions by regularly parsing the output of the df command in Linux
-- systems.
--
-----------------------------------------------------------------------------
module System.Taffybar.Widget.FSMonitor ( fsMonitorNew ) where
import Control.Monad.IO.Class
import qualified GI.Gtk
import System.Process ( readProcess )
import System.Taffybar.Widget.Generic.PollingLabel ( pollingLabelNew )
import qualified Data.Text as T
-- | Creates a new filesystem monitor widget. It contains one 'PollingLabel'
-- that displays the data returned by the df command. The usage level of all
-- requested partitions is extracted in one single operation.
fsMonitorNew
:: MonadIO m
=> Double -- ^ Polling interval (in seconds, e.g. 500)
-> [String] -- ^ Names of the partitions to monitor (e.g. [\"\/\", \"\/home\"])
-> m GI.Gtk.Widget
fsMonitorNew interval fsList = liftIO $ do
label <- pollingLabelNew "" interval $ showFSInfo fsList
GI.Gtk.widgetShowAll label
GI.Gtk.toWidget label
showFSInfo :: [String] -> IO T.Text
showFSInfo fsList = do
fsOut <- readProcess "df" ("-kP":fsList) ""
let fss = map (take 2 . reverse . words) $ drop 1 $ lines fsOut
return $ T.pack $ unwords $ map ((\s -> "[" ++ s ++ "]") . unwords) fss
taffybar-3.0.0/src/System/Taffybar/Widget/FreedesktopNotifications.hs 0000644 0000000 0000000 00000024553 13317725701 024112 0 ustar 00 0000000 0000000 {-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
-- | This widget listens on DBus for freedesktop notifications
-- (http://developer.gnome.org/notification-spec/). 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 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
-- | 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 :: Chan () -- ^ 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 <- newChan
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 (fromIntegral $ T.length summary)
escapedBody <- markupEscapeText body (fromIntegral $ T.length body)
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 = writeChan (noteChan s) ()
-- | Refreshes the GUI
displayThread :: NotifyState -> IO ()
displayThread s = forever $ do
() <- readChan (noteChan s)
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^(6 :: 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 <- hBoxNew False 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 <- hBoxNew False 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.0.0/src/System/Taffybar/Widget/Workspaces.hs 0000644 0000000 0000000 00000070370 13317725701 021224 0 ustar 00 0000000 0000000 {-# OPTIONS_GHC -fno-warn-type-defaults #-}
{-# LANGUAGE ScopedTypeVariables, ExistentialQuantification, RankNTypes, OverloadedStrings #-}
-----------------------------------------------------------------------------
-- |
-- Module : System.Taffybar.Widget.Workspaces
-- Copyright : (c) Ivan A. Malison
-- License : BSD3-style (see LICENSE)
--
-- Maintainer : Ivan A. Malison
-- Stability : unstable
-- Portability : unportable
-----------------------------------------------------------------------------
module System.Taffybar.Widget.Workspaces where
import Control.Applicative
import Control.Arrow ((&&&))
import Control.Concurrent
import qualified Control.Concurrent.MVar as MV
import Control.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.Char as Char
import qualified Data.Foldable as F
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 :: WorkspaceIdx
, workspaceName :: String
, workspaceState :: WorkspaceState
, windows :: [WindowData]
} deriving (Show, Eq)
data WorkspacesContext = WorkspacesContext
{ controllersVar :: MV.MVar (M.Map WorkspaceIdx WWC)
, workspacesVar :: MV.MVar (M.Map WorkspaceIdx Workspace)
, workspacesWidget :: Gtk.HBox
, 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 =
[ "WM_HINTS"
, "_NET_CURRENT_DESKTOP"
, "_NET_DESKTOP_NAMES"
, "_NET_NUMBER_OF_DESKTOPS"
, "_NET_WM_DESKTOP"
, "_NET_WM_STATE_HIDDEN"
]
, 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 WorkspaceIdx Workspace)
updateWorkspacesVar = do
workspacesRef <- asks workspacesVar
updateVar workspacesRef buildWorkspaceData
getWorkspaceToWindows :: [X11Window] -> X11Property (MM.MultiMap WorkspaceIdx X11Window)
getWorkspaceToWindows =
foldM
(\theMap window ->
MM.insert <$> getWorkspace window <*> pure window <*> pure theMap)
MM.empty
getWindowData :: [X11Window]
-> [X11Window]
-> X11Window
-> X11Property WindowData
getWindowData activeWindows urgentWindows window = do
wTitle <- getWindowTitle window
wClass <- getWindowClass window
wMinimized <- getWindowStateProperty window "_NET_WM_STATE_HIDDEN"
return
WindowData
{ windowId = window
, windowTitle = wTitle
, windowClass = wClass
, windowUrgent = window `elem` urgentWindows
, windowActive = window `elem` activeWindows
, windowMinimized = wMinimized
}
buildWorkspaceData :: M.Map WorkspaceIdx Workspace
-> WorkspacesIO (M.Map WorkspaceIdx Workspace)
buildWorkspaceData _ = ask >>= \context -> liftX11Def M.empty $ do
names <- getWorkspaceNames
wins <- getWindows
workspaceToWindows <- getWorkspaceToWindows wins
urgentWindows <- filterM isWindowUrgent wins
activeWindows <- readAsListOfWindow Nothing "_NET_ACTIVE_WINDOW"
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 activeWindows 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.hBoxNew False 0
parent <- Gtk.widgetGetParent workspaceWidget
if isJust parent
then Gtk.widgetReparent workspaceWidget hbox
else Gtk.containerAdd hbox workspaceWidget
Gtk.containerAdd cont hbox
workspacesNew :: WorkspacesConfig -> TaffyIO Gtk.Widget
workspacesNew cfg = ask >>= \tContext -> lift $ do
cont <- Gtk.hBoxNew False $ 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
(workspaceSubscription, iconSubscription) <-
flip runReaderT tContext $ sequenceT
( subscribeToEvents (updateEvents cfg) $ lift . updateHandler
, subscribeToEvents ["_NET_WM_ICON"] (lift . onIconChanged iconHandler)
)
let doUnsubscribe = flip runReaderT tContext $
mapM_ unsubscribe [iconSubscription, workspaceSubscription]
_ <- 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 :: (WorkspaceIdx -> 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.hBoxNew False 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.HBox
, iconImages :: [IconWidget]
, iconWorkspace :: Workspace
}
buildIconController :: ControllerConstructor
buildIconController ws = do
tempController <-
lift $ do
hbox <- Gtk.hBoxNew False 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)
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 -> WorkspaceIdx -> 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.0.0/src/System/Taffybar/Widget/CommandRunner.hs 0000644 0000000 0000000 00000003446 13317725701 021653 0 ustar 00 0000000 0000000 {-# LANGUAGE OverloadedStrings #-}
--------------------------------------------------------------------------------
-- |
-- Module : System.Taffybar.Widget.CommandRunner
-- Copyright : (c) Arseniy Seroka
-- License : BSD3-style (see LICENSE)
--
-- Maintainer : Arseniy Seroka
-- Stability : unstable
-- Portability : unportable
--
-- Simple function which runs user defined command and
-- returns it's output in PollingLabel widget
--------------------------------------------------------------------------------
module System.Taffybar.Widget.CommandRunner ( commandRunnerNew ) where
import Control.Monad.IO.Class
import qualified GI.Gtk
import System.Log.Logger
import System.Taffybar.Util
import System.Taffybar.Widget.Generic.PollingLabel
import Text.Printf
import qualified Data.Text as T
-- | Creates a new command runner widget. This is a 'PollingLabel' fed by
-- regular calls to command given by argument. The results of calling this
-- function are displayed as string.
commandRunnerNew
:: MonadIO m
=> Double -- ^ Polling period (in seconds).
-> String -- ^ Command to execute. Should be in $PATH or an absolute path
-> [String] -- ^ Command argument. May be @[]@
-> T.Text -- ^ If command fails this will be displayed.
-> m GI.Gtk.Widget
commandRunnerNew interval cmd args defaultOutput =
pollingLabelNew "" interval $
runCommandWithDefault cmd args defaultOutput
runCommandWithDefault :: FilePath -> [String] -> T.Text -> IO T.Text
runCommandWithDefault cmd args def =
T.filter (/= '\n') <$> (runCommand cmd args >>= either logError (return . T.pack))
where logError err =
logM "System.Taffybar.Widget.CommandRunner" ERROR
(printf "Got error in CommandRunner %s" err) >> return def
taffybar-3.0.0/src/System/Taffybar/Widget/XDGMenu/ 0000755 0000000 0000000 00000000000 13317725701 020007 5 ustar 00 0000000 0000000 taffybar-3.0.0/src/System/Taffybar/Widget/XDGMenu/MenuWidget.hs 0000644 0000000 0000000 00000011236 13317725701 022416 0 ustar 00 0000000 0000000 -----------------------------------------------------------------------------
-- |
-- Module : System.Taffybar.Widget.XDGMenu.MenuWidget
-- Copyright : 2017 Ulf Jasper
-- License : BSD3-style (see LICENSE)
--
-- Maintainer : Ulf Jasper
-- Stability : unstable
-- Portability : unportable
--
-- MenuWidget provides a hierachical GTK menu containing all
-- applicable desktop entries found on the system. The menu is built
-- according to the version 1.1 of the XDG "Desktop Menu
-- Specification", see
-- https://specifications.freedesktop.org/menu-spec/menu-spec-1.1.html
-----------------------------------------------------------------------------
module System.Taffybar.Widget.XDGMenu.MenuWidget
(
-- * Usage
-- $usage
menuWidgetNew
)
where
import Control.Monad
import Control.Monad.IO.Class
import qualified Data.Text as T
import GI.Gtk hiding (Menu)
import GI.GdkPixbuf
import System.Directory
import System.FilePath.Posix
import System.Process
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.
-- | 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 <- imageMenuItemNewWithLabel (feName de)
setWidgetTooltipText item (feComment de)
setIcon item (T.unpack <$> feIcon de)
menuShellAppend ms item
_ <- onMenuItemActivate item $ do
let cmd = feCommand de
putStrLn $ "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 -- ^ GTK menu
-> Menu -- ^ menu
-> IO ()
addMenu ms fm = do
let subMenus = fmSubmenus fm
items = fmEntries fm
when (not (null items) || not (null subMenus)) $ do
item <- imageMenuItemNewWithLabel (T.pack $ fmName fm)
setIcon item (fmIcon fm)
menuShellAppend ms item
subMenu <- menuNew
menuItemSetSubmenu item (Just subMenu)
mapM_ (addMenu subMenu) subMenus
mapM_ (addItem subMenu) items
setIcon :: ImageMenuItem -> Maybe String -> IO ()
setIcon _ Nothing = return ()
setIcon item (Just iconName) = do
iconTheme <- iconThemeGetDefault
hasIcon <- iconThemeHasIcon iconTheme (T.pack iconName)
mImg <- if hasIcon
then Just <$> imageNewFromIconName (Just $ T.pack iconName) (fromIntegral $ fromEnum IconSizeMenu)
else if isAbsolute iconName
then
do
ex <- doesFileExist iconName
if ex
then do let defaultSize = 24 -- FIXME should auto-adjust to font size
pb <- pixbufNewFromFileAtScale iconName
defaultSize defaultSize True
Just <$> imageNewFromPixbuf (Just pb)
else return Nothing
else return Nothing
case mImg of
Just img -> imageMenuItemSetImage item (Just img)
Nothing -> putStrLn $ "Icon not found: " ++ iconName
-- | 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
-- -- | Show XDG Menu Widget in a standalone frame.
-- testMenuWidget :: IO ()
-- testMenuWidget = do
-- _ <- initGUI
-- window <- windowNew
-- _ <- window `on` deleteEvent $ liftIO mainQuit >> return False
-- containerAdd window =<< menuWidgetNew Nothing
-- widgetShowAll window
-- mainGUI
taffybar-3.0.0/src/System/Taffybar/Widget/XDGMenu/Menu.hs 0000644 0000000 0000000 00000011051 13317725701 021245 0 ustar 00 0000000 0000000 -----------------------------------------------------------------------------
-- |
-- Module : System.Taffybar.Widget.XDGMenu.Menu
-- Copyright : 2017 Ulf Jasper
-- License : BSD3-style (see LICENSE)
--
-- Maintainer : Ulf Jasper
-- Stability : unstable
-- Portability : unportable
--
-- Implementation of version 1.1 of the freedesktop "Desktop Menu
-- Specification", see
-- https://specifications.freedesktop.org/menu-spec/menu-spec-1.1.html
--
-- See also 'MenuWidget'.
-----------------------------------------------------------------------------
module System.Taffybar.Widget.XDGMenu.Menu
( Menu(..)
, MenuEntry(..)
, buildMenu
, getApplicationEntries
) where
import Data.Char (toLower)
import Data.List
import Data.Maybe
import qualified Data.Text as T
import System.Taffybar.Information.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 (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.0.0/src/System/Taffybar/Widget/Text/ 0000755 0000000 0000000 00000000000 13317725701 017464 5 ustar 00 0000000 0000000 taffybar-3.0.0/src/System/Taffybar/Widget/Text/NetworkMonitor.hs 0000644 0000000 0000000 00000004567 13317725701 023035 0 ustar 00 0000000 0000000 module System.Taffybar.Widget.Text.NetworkMonitor where
import Control.Monad
import Control.Monad.Trans.Class
import qualified Data.Text as T
import GI.Gtk
import System.Taffybar.Context
import System.Taffybar.Hooks
import System.Taffybar.Information.Network
import System.Taffybar.Util
import System.Taffybar.Widget.Generic.ChannelWidget
import Text.Printf
import Text.StringTemplate
defaultNetFormat :: String
defaultNetFormat = "▼ $inAuto$ ▲ $outAuto$"
showInfo :: String -> Int -> (Double, Double) -> T.Text
showInfo template prec (incomingb, outgoingb) =
let
attribs = [ ("inB", show incomingb)
, ("inKB", toKB prec incomingb)
, ("inMB", toMB prec incomingb)
, ("inAuto", toAuto prec incomingb)
, ("outB", show outgoingb)
, ("outKB", toKB prec outgoingb)
, ("outMB", toMB prec outgoingb)
, ("outAuto", toAuto prec outgoingb)
]
in
render . setManyAttrib attribs $ newSTMP template
toKB :: Int -> Double -> String
toKB prec = setDigits prec . (/1024)
toMB :: Int -> Double -> String
toMB prec = setDigits prec . (/ (1024 * 1024))
setDigits :: Int -> Double -> String
setDigits dig = printf format
where format = "%." ++ show dig ++ "f"
toAuto :: Int -> Double -> String
toAuto prec value = printf "%.*f%s" p v unit
where value' = max 0 value
mag :: Int
mag = if value' == 0 then 0 else max 0 $ min 4 $ floor $ logBase 1024 value'
v = value' / 1024 ** fromIntegral mag
unit = case mag of
0 -> "B/s"
1 -> "KiB/s"
2 -> "MiB/s"
3 -> "GiB/s"
4 -> "TiB/s"
_ -> "??B/s" -- unreachable
p :: Int
p = max 0 $ floor $ fromIntegral prec - logBase 10 v
networkMonitorNew :: String -> Maybe [String] -> TaffyIO GI.Gtk.Widget
networkMonitorNew template interfaces = do
NetworkInfoChan chan <- getNetworkChan
let filterFn = maybe (const True) (flip elem) interfaces
label <- lift $ labelNew Nothing
void $ channelWidgetNew label chan $ \speedInfo ->
let (up, down) = sumSpeeds $ map snd $ filter (filterFn . fst) speedInfo
labelString = showInfo template 3 (fromRational down, fromRational up)
in postGUIASync $ labelSetMarkup label labelString
toWidget label
taffybar-3.0.0/src/System/Taffybar/Widget/Text/CPUMonitor.hs 0000644 0000000 0000000 00000002352 13317725701 022021 0 ustar 00 0000000 0000000 module System.Taffybar.Widget.Text.CPUMonitor (textCpuMonitorNew) where
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
import qualified Data.Text as T
-- | Creates a simple textual CPU monitor. It updates once every polling
-- period (in seconds).
textCpuMonitorNew :: String -- ^ Format. You can use variables: $total$, $user$, $system$
-> Double -- ^ Polling period (in seconds)
-> IO GI.Gtk.Widget
textCpuMonitorNew fmt period = do
label <- pollingLabelNew (T.pack fmt) period callback
GI.Gtk.widgetShowAll label
return 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.0.0/src/System/Taffybar/Widget/Text/MemoryMonitor.hs 0000644 0000000 0000000 00000002417 13317725701 022644 0 ustar 00 0000000 0000000 module System.Taffybar.Widget.Text.MemoryMonitor (textMemoryMonitorNew) where
import qualified Text.StringTemplate as ST
import System.Taffybar.Information.Memory
import System.Taffybar.Widget.Generic.PollingLabel ( pollingLabelNew )
import qualified GI.Gtk
import qualified Data.Text as T
-- | Creates a simple textual memory monitor. It updates once every polling
-- period (in seconds).
textMemoryMonitorNew :: String -- ^ Format. You can use variables: "used", "total", "free", "buffer", "cache", "rest", "used".
-> Double -- ^ Polling period in seconds.
-> IO GI.Gtk.Widget
textMemoryMonitorNew fmt period = do
label <- pollingLabelNew (T.pack fmt) period callback
GI.Gtk.widgetShowAll label
return 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.0.0/src/System/Taffybar/Widget/Generic/ 0000755 0000000 0000000 00000000000 13317725701 020114 5 ustar 00 0000000 0000000 taffybar-3.0.0/src/System/Taffybar/Widget/Generic/Graph.hs 0000644 0000000 0000000 00000021263 13317725701 021515 0 ustar 00 0000000 0000000 {-# LANGUAGE ScopedTypeVariables #-}
-- | This is a graph widget inspired by the widget of the same name in
-- Awesome (the window manager). It plots a series of data points
-- similarly to a bar graph. This version must be explicitly fed data
-- with 'graphAddSample'. For a more automated version, see
-- '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.Gtk as Gtk
import qualified Graphics.Rendering.Cairo as C
import qualified Graphics.Rendering.Cairo.Matrix as M
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 ctx (drawGraph mv drawArea) >> return True)
box <- Gtk.hBoxNew False 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.0.0/src/System/Taffybar/Widget/Generic/ChannelGraph.hs 0000644 0000000 0000000 00000001262 13317725701 023003 0 ustar 00 0000000 0000000 module System.Taffybar.Widget.Generic.ChannelGraph where
import Control.Concurrent
import Control.Monad
import Control.Monad.IO.Class
import GI.Gtk
import System.Taffybar.Widget.Generic.Graph
channelGraphNew
:: MonadIO m
=> GraphConfig -> Chan a -> (a -> IO [Double]) -> m GI.Gtk.Widget
channelGraphNew config chan sampleBuilder = do
(graphWidget, graphHandle) <- graphNew config
_ <- onWidgetRealize graphWidget $ do
ourChan <- dupChan chan
sampleThread <- forkIO $ forever $ do
value <- readChan ourChan
sampleBuilder value >>= graphAddSample graphHandle
void $ onWidgetUnrealize graphWidget $ killThread sampleThread
return graphWidget
taffybar-3.0.0/src/System/Taffybar/Widget/Generic/Icon.hs 0000644 0000000 0000000 00000003677 13317725701 021355 0 ustar 00 0000000 0000000 -- | This is a simple static image widget, and a polling image widget that
-- updates its contents by calling a callback at a set interval.
module System.Taffybar.Widget.Generic.Icon
( iconImageWidgetNew
, 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 <- hBoxNew False 0
boxPackStart box icon False False 0
widgetShowAll box
toWidget box
ignoreIOException :: IOException -> IO ()
ignoreIOException _ = return ()
taffybar-3.0.0/src/System/Taffybar/Widget/Generic/PollingLabel.hs 0000644 0000000 0000000 00000004427 13317725701 023023 0 ustar 00 0000000 0000000 -- | This is a simple text widget that updates its contents by calling
-- a callback at a set interval.
module System.Taffybar.Widget.Generic.PollingLabel
( pollingLabelNew
, pollingLabelNewWithTooltip
) where
import Control.Concurrent
import Control.Exception.Enclosed as E
import Control.Monad
import Control.Monad.IO.Class
import System.Taffybar.Util
import qualified Data.Text as T
import GI.Gtk
import System.Taffybar.Util
import System.Taffybar.Widget.Util
-- | 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
=> T.Text -- ^ Initial value for the label
-> Double -- ^ Update interval (in seconds)
-> IO T.Text -- ^ Command to run to get the input string
-> m GI.Gtk.Widget
pollingLabelNew initialString interval cmd =
pollingLabelNewWithTooltip initialString interval $ (, Nothing) <$> cmd
pollingLabelNewWithTooltip
:: MonadIO m
=> T.Text -- ^ Initial value for the label
-> Double -- ^ Update interval (in seconds)
-> IO (T.Text, Maybe T.Text) -- ^ Command to run to get the input string
-> m GI.Gtk.Widget
pollingLabelNewWithTooltip initialString interval cmd =
liftIO $ do
grid <- gridNew
label <- labelNew $ Just initialString
let updateLabel (labelStr, tooltipStr) =
postGUIASync $ do
labelSetMarkup label labelStr
widgetSetTooltipMarkup label tooltipStr
_ <- onWidgetRealize label $ do
sampleThread <- foreverWithDelay interval $ E.tryAny cmd >>= either (const $ return ()) updateLabel
void $ onWidgetUnrealize label $ killThread sampleThread
vFillCenter label
vFillCenter grid
containerAdd grid label
widgetShowAll grid
toWidget grid
taffybar-3.0.0/src/System/Taffybar/Widget/Generic/PollingGraph.hs 0000644 0000000 0000000 00000002164 13317725701 023041 0 ustar 00 0000000 0000000 -- | A variant of the Graph widget that automatically updates itself
-- with a callback at a fixed interval.
module System.Taffybar.Widget.Generic.PollingGraph (
-- * Types
GraphHandle,
GraphConfig(..),
GraphDirection(..),
GraphStyle(..),
-- * Constructors and accessors
pollingGraphNew,
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.0.0/src/System/Taffybar/Widget/Generic/AutoSizeImage.hs 0000644 0000000 0000000 00000014070 13317725701 023160 0 ustar 00 0000000 0000000 {-# LANGUAGE OverloadedStrings #-}
module System.Taffybar.Widget.Generic.AutoSizeImage where
import qualified Control.Concurrent.MVar as MV
import Control.Monad
import Control.Monad.IO.Class
import Data.Int
import Data.Maybe
import qualified 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
taffybar-3.0.0/src/System/Taffybar/Widget/Generic/PollingBar.hs 0000644 0000000 0000000 00000002234 13317725701 022502 0 ustar 00 0000000 0000000 -- | Like the vertical bar, but this widget automatically updates
-- itself with a callback at fixed intervals.
module System.Taffybar.Widget.Generic.PollingBar (
-- * Types
VerticalBarHandle,
BarConfig(..),
BarDirection(..),
-- * Constructors and accessors
pollingBarNew,
verticalBarFromCallback,
defaultBarConfig
) where
import Control.Concurrent
import Control.Exception.Enclosed ( tryAny )
import qualified GI.Gtk
import System.Taffybar.Widget.Util ( backgroundLoop )
import Control.Monad.IO.Class
import System.Taffybar.Widget.Generic.VerticalBar
verticalBarFromCallback :: MonadIO m
=> BarConfig -> IO Double -> m GI.Gtk.Widget
verticalBarFromCallback cfg action = liftIO $ do
(drawArea, h) <- verticalBarNew cfg
_ <- GI.Gtk.onWidgetRealize drawArea $ backgroundLoop $ do
esample <- tryAny action
traverse (verticalBarSetPercent h) esample
return drawArea
pollingBarNew :: MonadIO m
=> BarConfig -> Double -> IO Double -> m GI.Gtk.Widget
pollingBarNew cfg pollSeconds action =
liftIO $
verticalBarFromCallback cfg $ action <* delay
where delay = threadDelay $ floor (pollSeconds * 1000000)
taffybar-3.0.0/src/System/Taffybar/Widget/Generic/DynamicMenu.hs 0000644 0000000 0000000 00000001603 13317725701 022661 0 ustar 00 0000000 0000000 module System.Taffybar.Widget.Generic.DynamicMenu where
import Control.Monad.IO.Class
import qualified GI.Gtk as Gtk
data DynamicMenuConfig = DynamicMenuConfig
{ dmClickWidget :: Gtk.Widget
, dmPopulateMenu :: Gtk.Menu -> IO ()
}
dynamicMenuNew :: MonadIO m => DynamicMenuConfig -> m Gtk.Widget
dynamicMenuNew DynamicMenuConfig
{ dmClickWidget = clickWidget
, dmPopulateMenu = populateMenu
} = do
button <- Gtk.menuButtonNew
menu <- Gtk.menuNew
Gtk.containerAdd button clickWidget
Gtk.menuButtonSetPopup button $ Just menu
_ <- Gtk.onButtonPressed button $ emptyMenu menu >> populateMenu menu
Gtk.widgetShowAll button
Gtk.toWidget button
emptyMenu :: (Gtk.IsContainer a, MonadIO m) => a -> m ()
emptyMenu menu =
Gtk.containerForeach menu $ \item ->
Gtk.containerRemove menu item >> Gtk.widgetDestroy item
taffybar-3.0.0/src/System/Taffybar/Widget/Generic/VerticalBar.hs 0000644 0000000 0000000 00000014111 13317725701 022644 0 ustar 00 0000000 0000000 -- | A vertical bar that can plot data in the range [0, 1]. The
-- colors are configurable.
module System.Taffybar.Widget.Generic.VerticalBar (
-- * Types
VerticalBarHandle,
BarConfig(..),
BarDirection(..),
-- * Accessors/Constructors
verticalBarNew,
verticalBarSetPercent,
defaultBarConfig,
defaultBarConfigIO
) where
import Control.Concurrent
import Control.Monad
import Control.Monad.IO.Class
import GI.Gtk hiding (widgetGetAllocatedSize)
import qualified Graphics.Rendering.Cairo as C
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 ctx (drawBar mv drawArea) >> return True
box <- hBoxNew False 1
boxPackStart box drawArea True True 0
widgetShowAll box
giBox <- toWidget box
return (giBox, VBH mv)
taffybar-3.0.0/src/System/Taffybar/Widget/Generic/ChannelWidget.hs 0000644 0000000 0000000 00000001037 13317725701 023165 0 ustar 00 0000000 0000000 module System.Taffybar.Widget.Generic.ChannelWidget where
import Control.Concurrent
import Control.Monad
import Control.Monad.IO.Class
import GI.Gtk
channelWidgetNew :: (MonadIO m, IsWidget w) => w -> Chan a -> (a -> IO ()) -> m w
channelWidgetNew widget channel updateWidget = do
void $ onWidgetRealize widget $ do
ourChan <- dupChan channel
processingThreadId <- forkIO $ forever $
readChan ourChan >>= updateWidget
void $ onWidgetUnrealize widget $ killThread processingThreadId
widgetShowAll widget
return widget
taffybar-3.0.0/app/ 0000755 0000000 0000000 00000000000 13317725701 012264 5 ustar 00 0000000 0000000 taffybar-3.0.0/app/Main.hs 0000644 0000000 0000000 00000002043 13317725701 013503 0 ustar 00 0000000 0000000 -- | 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.Log.Logger
import System.Taffybar
import System.Taffybar.Context
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 gtk-sni-tray"
)
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
dyreTaffybar defaultTaffybarConfig