Browse Source

Get everything building again after 2 years of neglect

master
Peter J. Jones 6 months ago
parent
commit
7cf9eddeeb
Signed by: Peter Jones <pjones@devalot.com> GPG Key ID: 9DAFAA8D01941E49
75 changed files with 183 additions and 4107 deletions
  1. 1
    5
      .gitignore
  2. 0
    18
      .gitmodules
  3. 0
    8
      cabal.project
  4. 16
    0
      default.nix
  5. 0
    24
      etc/taffybar.gtk
  6. 18
    0
      nix/xmonad-contrib.cabal.nix
  7. 7
    0
      nix/xmonad-contrib.json
  8. 13
    0
      nix/xmonad-contrib.nix
  9. 26
    0
      nix/xmonad.cabal.nix
  10. 7
    0
      nix/xmonad.json
  11. 13
    0
      nix/xmonad.nix
  12. 0
    36
      script/git-remotes.sh
  13. 2
    2
      src/XMonad/Local/Keys.hs
  14. 2
    6
      src/XMonad/Local/Layout.hs
  15. 15
    12
      src/XMonad/Local/Music.hs
  16. 0
    1
      vendor/playlists
  17. 0
    1
      vendor/playlists-http
  18. 0
    1
      vendor/taffybar/.gitignore
  19. 0
    74
      vendor/taffybar/.travis.yml
  20. 0
    87
      vendor/taffybar/CHANGELOG.md
  21. 0
    30
      vendor/taffybar/LICENSE
  22. 0
    39
      vendor/taffybar/README.md
  23. 0
    2
      vendor/taffybar/Setup.hs
  24. BIN
      vendor/taffybar/doc/screenshot.png
  25. 0
    7
      vendor/taffybar/src/Main.hs
  26. 0
    168
      vendor/taffybar/src/System/Information/Battery.hs
  27. 0
    33
      vendor/taffybar/src/System/Information/CPU.hs
  28. 0
    37
      vendor/taffybar/src/System/Information/CPU2.hs
  29. 0
    27
      vendor/taffybar/src/System/Information/DiskIO.hs
  30. 0
    112
      vendor/taffybar/src/System/Information/EWMHDesktopInfo.hs
  31. 0
    43
      vendor/taffybar/src/System/Information/Memory.hs
  32. 0
    40
      vendor/taffybar/src/System/Information/Network.hs
  33. 0
    62
      vendor/taffybar/src/System/Information/StreamInfo.hs
  34. 0
    156
      vendor/taffybar/src/System/Information/X11DesktopInfo.hs
  35. 0
    296
      vendor/taffybar/src/System/Taffybar.hs
  36. 0
    117
      vendor/taffybar/src/System/Taffybar/Battery.hs
  37. 0
    28
      vendor/taffybar/src/System/Taffybar/CPUMonitor.hs
  38. 0
    36
      vendor/taffybar/src/System/Taffybar/CommandRunner.hs
  39. 0
    24
      vendor/taffybar/src/System/Taffybar/DiskIOMonitor.hs
  40. 0
    25
      vendor/taffybar/src/System/Taffybar/FSMonitor.hs
  41. 0
    285
      vendor/taffybar/src/System/Taffybar/FreedesktopNotifications.hs
  42. 0
    76
      vendor/taffybar/src/System/Taffybar/Hooks/PagerHints.hs
  43. 0
    67
      vendor/taffybar/src/System/Taffybar/LayoutSwitcher.hs
  44. 0
    101
      vendor/taffybar/src/System/Taffybar/MPRIS.hs
  45. 0
    122
      vendor/taffybar/src/System/Taffybar/MPRIS2.hs
  46. 0
    67
      vendor/taffybar/src/System/Taffybar/NetMonitor.hs
  47. 0
    116
      vendor/taffybar/src/System/Taffybar/Pager.hs
  48. 0
    105
      vendor/taffybar/src/System/Taffybar/SimpleClock.hs
  49. 0
    34
      vendor/taffybar/src/System/Taffybar/StrutProperties.hs
  50. 0
    22
      vendor/taffybar/src/System/Taffybar/Systray.hs
  51. 0
    56
      vendor/taffybar/src/System/Taffybar/TaffyPager.hs
  52. 0
    27
      vendor/taffybar/src/System/Taffybar/Text/CPUMonitor.hs
  53. 0
    27
      vendor/taffybar/src/System/Taffybar/Text/MemoryMonitor.hs
  54. 0
    247
      vendor/taffybar/src/System/Taffybar/Weather.hs
  55. 0
    214
      vendor/taffybar/src/System/Taffybar/Widgets/Graph.hs
  56. 0
    31
      vendor/taffybar/src/System/Taffybar/Widgets/PollingBar.hs
  57. 0
    35
      vendor/taffybar/src/System/Taffybar/Widgets/PollingGraph.hs
  58. 0
    30
      vendor/taffybar/src/System/Taffybar/Widgets/PollingLabel.hs
  59. 0
    48
      vendor/taffybar/src/System/Taffybar/Widgets/Util.hs
  60. 0
    132
      vendor/taffybar/src/System/Taffybar/Widgets/VerticalBar.hs
  61. 0
    110
      vendor/taffybar/src/System/Taffybar/WindowSwitcher.hs
  62. 0
    214
      vendor/taffybar/src/System/Taffybar/WorkspaceSwitcher.hs
  63. 0
    101
      vendor/taffybar/src/System/Taffybar/XMonadLog.hs
  64. 0
    28
      vendor/taffybar/src/gdk_property_change_wrapper.c
  65. 0
    123
      vendor/taffybar/taffybar.cabal
  66. 0
    43
      vendor/taffybar/taffybar.hs.example
  67. 0
    26
      vendor/taffybar/taffybar.rc
  68. 0
    19
      vendor/taffybar/xmonad.hs.example
  69. 0
    1
      vendor/x11
  70. 0
    1
      vendor/x11-xft
  71. 0
    1
      vendor/xmonad
  72. 0
    1
      vendor/xmonad-contrib
  73. 38
    37
      xmonadrc.cabal
  74. 0
    3
      xmonadrc.hs
  75. 25
    0
      xmonadrc.nix

+ 1
- 5
.gitignore View File

@@ -1,6 +1,2 @@
/dist
/.stack-work
/build/.stack-work
/vendor/taffybar/.stack-work
/dist-newstyle
/cabal.project.local
/result

+ 0
- 18
.gitmodules View File

@@ -1,18 +0,0 @@
[submodule "vendor/xmonad"]
path = vendor/xmonad
url = https://github.com/pjones/xmonad.git
[submodule "vendor/xmonad-contrib"]
path = vendor/xmonad-contrib
url = https://github.com/pjones/xmonad-contrib.git
[submodule "vendor/playlists"]
path = vendor/playlists
url = git://git.devalot.com/playlists
[submodule "vendor/playlists-http"]
path = vendor/playlists-http
url = git://git.devalot.com/playlists-http
[submodule "vendor/x11"]
path = vendor/x11
url = https://github.com/xmonad/X11.git
[submodule "vendor/x11-xft"]
path = vendor/x11-xft
url = https://github.com/csstaub/X11-xft.git

+ 0
- 8
cabal.project View File

@@ -1,8 +0,0 @@
packages: ./
vendor/playlists
vendor/playlists-http
vendor/x11/
vendor/x11-xft/
vendor/xmonad/
vendor/xmonad-contrib
vendor/taffybar

+ 16
- 0
default.nix View File

@@ -0,0 +1,16 @@
{ pkgs ? import <nixpkgs> {}
}:

let
# Use my copy of some packages:
overrides = self: super: with pkgs.haskell.lib; {
xmonad = import ./nix/xmonad.nix { inherit pkgs; };
xmonad-contrib = import ./nix/xmonad-contrib.nix { inherit pkgs; };
};

# Apply the overrides from above:
haskell = pkgs.haskellPackages.override (orig: {
overrides = pkgs.lib.composeExtensions
(orig.overrides or (_: _: {})) overrides; });

in haskell.callPackage ./xmonadrc.nix { }

+ 0
- 24
etc/taffybar.gtk View File

@@ -1,24 +0,0 @@
gtk_color_scheme = "black:#191919\nwhite:#839496\ngreen:#859900\nred:#dc322f"

style "default" {
font_name = "Monospace 8"
bg[NORMAL] = @black
fg[NORMAL] = @white
text[NORMAL] = @white
fg[PRELIGHT] = @green
bg[PRELIGHT] = @black
}

style "active-window" = "default" {
fg[NORMAL] = @green
}

style "notification-button" = "default" {
text[NORMAL] = @red
fg[NORMAL] = @red
}

widget "Taffybar*" style "default"
widget "Taffybar*WindowSwitcher*label" style "active-window"
widget "*NotificationCloseButton" style "notification-button"


+ 18
- 0
nix/xmonad-contrib.cabal.nix View File

@@ -0,0 +1,18 @@
{ mkDerivation, base, bytestring, containers, directory
, extensible-exceptions, filepath, mtl, old-locale, old-time
, process, random, semigroups, stdenv, unix, utf8-string, X11
, X11-xft, xmonad
}:
mkDerivation {
pname = "xmonad-contrib";
version = "0.15";
src = ./.;
libraryHaskellDepends = [
base bytestring containers directory extensible-exceptions filepath
mtl old-locale old-time process random semigroups unix utf8-string
X11 X11-xft xmonad
];
homepage = "http://xmonad.org/";
description = "Third party extensions for xmonad";
license = stdenv.lib.licenses.bsd3;
}

+ 7
- 0
nix/xmonad-contrib.json View File

@@ -0,0 +1,7 @@
{
"url": "https://code.devalot.com/mirrors/xmonad-contrib.git",
"rev": "4ad6ecf892470a5202bf16784eeab4e365f7a90e",
"date": "2019-04-10T22:07:22-05:00",
"sha256": "1inmvg50lvc06awrg8i86bqhqgzrph0vm9p6n0sg97z0zyg9xax5",
"fetchSubmodules": false
}

+ 13
- 0
nix/xmonad-contrib.nix View File

@@ -0,0 +1,13 @@
# Pull in xmonad-contrib from my mirror:
{ pkgs ? import <nixpkgs> { }
}:

with pkgs.lib;

let
src = pkgs.fetchgit (removeAttrs (importJSON ./xmonad-contrib.json) ["date"]);
haskell = pkgs.haskellPackages;
withSrc = args: haskell.mkDerivation (args // { inherit src; });
in

haskell.callPackage ./xmonad-contrib.cabal.nix { mkDerivation = withSrc; }

+ 26
- 0
nix/xmonad.cabal.nix View File

@@ -0,0 +1,26 @@
{ mkDerivation, base, containers, data-default, directory
, extensible-exceptions, filepath, mtl, process, QuickCheck
, setlocale, stdenv, unix, utf8-string, X11
}:
mkDerivation {
pname = "xmonad";
version = "0.15";
src = ./.;
isLibrary = true;
isExecutable = true;
libraryHaskellDepends = [
base containers data-default directory extensible-exceptions
filepath mtl process setlocale unix utf8-string X11
];
executableHaskellDepends = [ base mtl unix X11 ];
testHaskellDepends = [
base containers extensible-exceptions QuickCheck X11
];
postInstall = ''
install -D man/xmonad.1 $doc/share/man/man1/xmonad.1
install -D man/xmonad.hs $doc/share/doc/$name/sample-xmonad.hs
'';
homepage = "http://xmonad.org";
description = "A tiling window manager";
license = stdenv.lib.licenses.bsd3;
}

+ 7
- 0
nix/xmonad.json View File

@@ -0,0 +1,7 @@
{
"url": "https://code.devalot.com/mirrors/xmonad.git",
"rev": "bb13853929f8f6fc59b526bcc10631e1bac309ad",
"date": "2018-09-30T13:34:01+02:00",
"sha256": "1f2w0vkv4i40sa52d0bxdhmn9zsikzymm91xwdi4m64nqwip1i97",
"fetchSubmodules": false
}

+ 13
- 0
nix/xmonad.nix View File

@@ -0,0 +1,13 @@
# Pull in xmonad from my mirror:
{ pkgs ? import <nixpkgs> { }
}:

with pkgs.lib;

let
src = pkgs.fetchgit (removeAttrs (importJSON ./xmonad.json) ["date"]);
haskell = pkgs.haskellPackages;
withSrc = args: haskell.mkDerivation (args // { inherit src; });
in

haskell.callPackage ./xmonad.cabal.nix { mkDerivation = withSrc; }

+ 0
- 36
script/git-remotes.sh View File

@@ -1,36 +0,0 @@
#!/bin/sh -eu

################################################################################
# Configure Git remote repositories.

################################################################################
set_remote() {
name=$1
url=$2

if git remote get-url "$name" > /dev/null 2>&1; then
git remote set-url "$name" "$url"
else
git remote add "$name" "$url"
fi
}

################################################################################
# xmonad
( cd vendor/xmonad
set_remote github https://github.com/pjones/xmonad.git
set_remote upstream https://github.com/xmonad/xmonad.git
)

################################################################################
# xmonad-contrib
( cd vendor/xmonad-contrib
set_remote github https://github.com/pjones/xmonad-contrib.git
set_remote upstream https://github.com/xmonad/xmonad-contrib.git
)

################################################################################
# x11
( cd vendor/x11
set_remote upstream https://github.com/xmonad/X11.git
)

+ 2
- 2
src/XMonad/Local/Keys.hs View File

@@ -219,8 +219,8 @@ layoutKeys c =
-- Keys to manipulate screens (actual physical monitors).
screenKeys :: XConfig Layout -> [(String, X ())]
screenKeys _ =
[ ("M-s M-f", onNextNeighbour W.view)
, ("M-s M-b", onPrevNeighbour W.view)
[ ("M-s M-f", onNextNeighbour def W.view)
, ("M-s M-b", onPrevNeighbour def W.view)
, ("M-s M-s", screenSwap L True)
, ("M1-<F11>", spawn "xbacklight -dec 10")
, ("M1-<F12>", spawn "xbacklight -inc 10")

+ 2
- 6
src/XMonad/Local/Layout.hs View File

@@ -22,16 +22,13 @@ import XMonad.Layout.LayoutCombinators
import XMonad.Layout.LayoutModifier
import XMonad.Layout.Master (mastered)
import XMonad.Layout.NoBorders (noBorders)
import XMonad.Layout.NoFrillsDecoration
import XMonad.Layout.Reflect (reflectHoriz, reflectVert)
import XMonad.Layout.Renamed (Rename(..), renamed)
import XMonad.Layout.ResizableTile (ResizableTall(..))
import XMonad.Layout.Spacing (spacing)
import XMonad.Layout.ThreeColumns (ThreeCol(..))
import XMonad.Layout.ToggleLayouts (toggleLayouts)
import XMonad.Layout.TwoPane (TwoPane(..))
import XMonad.Local.Prompt (aListCompFunc)
import XMonad.Local.Theme (topBarTheme)
import XMonad.Prompt
import XMonad.Util.Types (Direction2D(..))

@@ -41,10 +38,9 @@ import XMonad.Util.Types (Direction2D(..))
layoutHook =
toggleLayouts
(noBorders fullscreen)
(addDeco $ addSpace allLays)
allLays
where
addDeco = renamed [CutWordsLeft 1] . noFrillsDeco shrinkText topBarTheme
addSpace = renamed [CutWordsLeft 2] . spacing 4
-- addSpace = renamed [CutWordsLeft 2] . spacingRaw 4

fullscreen :: ModifiedLayout Rename (ModifiedLayout Gaps Full) Window
fullscreen = renamed [Replace "Full"] (gaps (uniformGaps 60) Full)

+ 15
- 12
src/XMonad/Local/Music.hs View File

@@ -1,3 +1,4 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}

--------------------------------------------------------------------------------
@@ -15,10 +16,9 @@ module XMonad.Local.Music (radioPrompt) where
--------------------------------------------------------------------------------
import Control.Exception
import Control.Monad (when, void)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Except (MonadError(..), runExceptT, liftEither)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Random (evalRandIO, uniform)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Either
import qualified Data.ByteString as ByteString
import Data.List (find)
import Data.Maybe (mapMaybe)
@@ -78,20 +78,23 @@ radioPrompt c = do

--------------------------------------------------------------------------------
playStream :: Playlist -> String -> X ()
playStream playlist title = void $ runEitherT $ do
url <- findTrack (Text.pack title)
manager <- liftIO (newManager defaultManagerSettings)
streams <- hoistEither =<< download (env manager) url
track <- pickTrack streams
lift (playURL $ trackURL track)
playStream playlist title = do
track <- runExceptT $ do
url <- findTrack (Text.pack title)
manager <- liftIO (newManager defaultManagerSettings)
streams <- liftEither =<< download (env manager) url
pickTrack streams
case track of
Left _ -> return ()
Right t -> playURL (trackURL t)
where
findTrack :: Text -> EitherT Error X Text
findTrack :: (MonadError Error m) => Text -> m Text
findTrack name =
case find (\t -> trackTitle t == Just name) playlist of
Nothing -> left (InvalidURL name)
Nothing -> throwError (InvalidURL name)
Just track -> return (trackURL track)

pickTrack :: Playlist -> EitherT Error X Track
pickTrack :: (MonadIO m) => Playlist -> m Track
pickTrack = liftIO . evalRandIO . uniform

env :: Manager -> Environment

+ 0
- 1
vendor/playlists

@@ -1 +0,0 @@
Subproject commit 8d39a0856878932095adb3d68b73d14306ea25f4

+ 0
- 1
vendor/playlists-http

@@ -1 +0,0 @@
Subproject commit 876912294f34f42fe6a68f62d8d5a85180414848

+ 0
- 1
vendor/taffybar/.gitignore View File

@@ -1 +0,0 @@
/dist/

+ 0
- 74
vendor/taffybar/.travis.yml View File

@@ -1,74 +0,0 @@
# This file has been generated -- see https://github.com/hvr/multi-ghc-travis
language: c
sudo: false

cache:
directories:
- $HOME/.cabsnap
- $HOME/.cabal/packages

before_cache:
- rm -fv $HOME/.cabal/packages/hackage.haskell.org/build-reports.log
- rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.tar

matrix:
include:
- env: CABALVER=1.18 GHCVER=7.6.3
compiler: ": #GHC 7.6.3"
addons: {apt: {packages: [alex-3.1.4,happy-1.19.5,cabal-install-1.18,ghc-7.6.3,libgmp-dev,libgtk2.0-dev,libcairo2-dev,libglib2.0-dev], sources: [hvr-ghc]}}
- env: CABALVER=1.18 GHCVER=7.8.4
compiler: ": #GHC 7.8.4"
addons: {apt: {packages: [alex-3.1.4,happy-1.19.5,cabal-install-1.18,ghc-7.8.4,libgmp-dev,libgtk2.0-dev,libcairo2-dev,libglib2.0-dev], sources: [hvr-ghc]}}
- env: CABALVER=1.22 GHCVER=7.10.3
compiler: ": #GHC 7.10.3"
addons: {apt: {packages: [alex-3.1.4,happy-1.19.5,cabal-install-1.22,ghc-7.10.2,libgmp-dev,libgtk2.0-dev,libcairo2-dev,libglib2.0-dev], sources: [hvr-ghc]}}

before_install:
- unset CC
- export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:/opt/alex/3.1.4/bin:/opt/happy/1.19.5/bin:$PATH

install:
- cabal --version
- echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]"
- if [ -f $HOME/.cabal/packages/hackage.haskell.org/00-index.tar.gz ];
then
zcat $HOME/.cabal/packages/hackage.haskell.org/00-index.tar.gz >
$HOME/.cabal/packages/hackage.haskell.org/00-index.tar;
fi
- travis_retry cabal update -v
- sed -i 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config
- cabal install gtk2hs-buildtools
- cabal install --constraint='gtk >= 0.14' --constraint='cairo >= 0.13.1.1' --only-dependencies --enable-tests --enable-benchmarks --dry -v > installplan.txt
- sed -i -e '1,/^Resolving /d' installplan.txt; cat installplan.txt
# check whether current requested install-plan matches cached package-db snapshot
- if diff -u installplan.txt $HOME/.cabsnap/installplan.txt;
then
echo "cabal build-cache HIT";
rm -rfv .ghc;
cp -a $HOME/.cabsnap/ghc $HOME/.ghc;
cp -a $HOME/.cabsnap/lib $HOME/.cabsnap/share $HOME/.cabsnap/bin $HOME/.cabal/;
else
echo "cabal build-cache MISS";
rm -rf $HOME/.cabsnap;
mkdir -p $HOME/.ghc $HOME/.cabal/lib $HOME/.cabal/share $HOME/.cabal/bin;
cabal install --only-dependencies --enable-tests --enable-benchmarks --force-reinstalls;
fi

# snapshot package-db on cache miss
- if [ ! -d $HOME/.cabsnap ];
then
echo "snapshotting package-db to build-cache";
mkdir $HOME/.cabsnap;
cp -a $HOME/.ghc $HOME/.cabsnap/ghc;
cp -a $HOME/.cabal/lib $HOME/.cabal/share $HOME/.cabal/bin installplan.txt $HOME/.cabsnap/;
fi

# Here starts the actual work to be performed for the package under test;
# any command which exits with a non-zero exit code causes the build to fail.
script:
- if [ -f configure.ac ]; then autoreconf -i; fi
- cabal configure --enable-tests --enable-benchmarks -v2 # -v2 provides useful information for debugging
- cabal build # this builds all libraries and executables (including tests/benchmarks)
- cabal test

# EOF

+ 0
- 87
vendor/taffybar/CHANGELOG.md View File

@@ -1,87 +0,0 @@
# 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

+ 0
- 30
vendor/taffybar/LICENSE View File

@@ -1,30 +0,0 @@
Copyright (c)2011, 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.

+ 0
- 39
vendor/taffybar/README.md View File

@@ -1,39 +0,0 @@
This is a desktop information bar intended for use with XMonad and
similar window managers. It is similar in spirit to xmobar; it is
different in that it gives up some simplicity for a reasonable helping
of eye candy. This bar is based on GTK+ (via gtk2hs) and uses fancy
graphics where doing so is reasonable and useful. Example:

![](https://github.com/travitch/taffybar/blob/master/doc/screenshot.png)

The bar is configured much like XMonad. It uses
~/.config/taffybar/taffybar.hs as its configuration file. This file
is just a Haskell program that invokes the real _main_ function with a
configuration object. The configuration file basically just specifies
which widgets to use, though any arbitrary Haskell code can be
executed before the bar is created.

There are some generic pre-defined widgets available:

* Graph (modeled after the graph widget in Awesome)
* Vertical bar (also similar to a widget in Awesome)
* Periodically-updating labels, graphs, and vertical bars

There are also several more specialized widgets:

* Battery widget
* Textual clock
* Freedesktop.org notifications (via dbus)
* MPRIS1 and MPRIS2 widgets
* Weather widget
* XMonad log widget (listens on dbus instead of stdin)
* System tray

TODO
====

An incomplete list of things that would be cool to have:

* xrandr widget (for dealing changing clone/extend mode and orientation)
* Better behavior when adding/removing monitors (never tried it)
* Make MPRIS more configurable

+ 0
- 2
vendor/taffybar/Setup.hs View File

@@ -1,2 +0,0 @@
import Distribution.Simple
main = defaultMain

BIN
vendor/taffybar/doc/screenshot.png View File


+ 0
- 7
vendor/taffybar/src/Main.hs View File

@@ -1,9 +0,0 @@
module Main ( main ) where

import System.Taffybar

main :: IO ()
main = do
defaultTaffybar defaultTaffybarConfig

+ 0
- 168
vendor/taffybar/src/System/Information/Battery.hs View File

@@ -1,187 +0,0 @@
{-# LANGUAGE OverloadedStrings #-}
module System.Information.Battery (
-- * Types
BatteryContext,
BatteryInfo(..),
BatteryState(..),
BatteryTechnology(..),
BatteryType(..),
-- * Accessors
batteryContextNew,
getBatteryInfo
) where

import Data.Map ( Map )
import qualified Data.Map as M
import Data.Maybe ( fromMaybe )
import Data.Word
import Data.Int
import DBus
import DBus.Client
import Data.List ( find, isInfixOf )
import Data.Text ( Text )
import qualified Data.Text as T
import Safe ( atMay )

data BatteryContext = BC Client ObjectPath

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)

data BatteryInfo = BatteryInfo { batteryNativePath :: Text
, batteryVendor :: Text
, batteryModel :: Text
, batterySerial :: Text
-- , batteryUpdateTime :: Time
, batteryType :: BatteryType
, batteryPowerSupply :: Bool
, batteryHasHistory :: Bool
, batteryHasStatistics :: Bool
, batteryOnline :: Bool
, batteryEnergy :: Double
, batteryEnergyEmpty :: Double
, batteryEnergyFull :: Double
, batteryEnergyFullDesign :: Double
, batteryEnergyRate :: Double
, batteryVoltage :: Double
, batteryTimeToEmpty :: Int64
, batteryTimeToFull :: Int64
, batteryPercentage :: Double
, batteryIsPresent :: Bool
, batteryState :: BatteryState
, batteryIsRechargable :: Bool
, batteryCapacity :: Double
, batteryTechnology :: BatteryTechnology
{- , batteryRecallNotice :: Bool
, batteryRecallVendor :: Text
, batteryRecallUr :: Text
-}
}

firstBattery :: [ObjectPath] -> Maybe ObjectPath
firstBattery = find (isInfixOf "BAT" . formatObjectPath)

powerBusName :: BusName
powerBusName = "org.freedesktop.UPower"

powerBaseObjectPath :: ObjectPath
powerBaseObjectPath = "/org/freedesktop/UPower"

readDict :: (IsVariant a) => Map Text Variant -> Text -> a -> a
readDict dict key dflt = fromMaybe dflt $ do
variant <- M.lookup key dict
fromVariant variant

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

getBatteryInfo :: BatteryContext -> IO (Maybe BatteryInfo)
getBatteryInfo (BC systemConn battPath) = do
-- Grab all of the properties of the battery each call with one
-- message.
reply <- call_ systemConn (methodCall battPath "org.freedesktop.DBus.Properties" "GetAll")
{ methodCallDestination = Just "org.freedesktop.UPower"
, methodCallBody = [toVariant $ T.pack "org.freedesktop.UPower.Device"]
}

return $ do
body <- methodReturnBody reply `atMay` 0
dict <- fromVariant body
return 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
, batteryIsRechargable = readDict dict "IsRechargable" True
, batteryCapacity = readDict dict "Capacity" 0.0
, batteryTechnology =
toEnum $ fromIntegral $ readDictIntegral dict "Technology" 0
}

batteryContextNew :: IO (Maybe BatteryContext)
batteryContextNew = do
systemConn <- connectSystem

-- First, get the list of devices. For now, we just get the stats
-- for the first battery
reply <- call_ systemConn (methodCall powerBaseObjectPath "org.freedesktop.UPower" "EnumerateDevices")
{ methodCallDestination = Just powerBusName
}
return $ do
body <- methodReturnBody reply `atMay` 0
powerDevices <- fromVariant body
battPath <- firstBattery powerDevices
return $ BC systemConn battPath

+ 0
- 33
vendor/taffybar/src/System/Information/CPU.hs View File

@@ -1,35 +0,0 @@
module System.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

cpuLoad :: IO (Double, Double, Double)
cpuLoad = do
a <- procData
threadDelay 50000
b <- procData
let dif = zipWith (-) b a
tot = foldr (+) 0 dif
pct = map (/ tot) dif
user = foldr (+) 0 $ take 2 pct
system = pct !! 2
t = user + system
return (truncVal user, truncVal system, truncVal t)

+ 0
- 37
vendor/taffybar/src/System/Information/CPU2.hs View File

@@ -1,57 +0,0 @@
-----------------------------------------------------------------------------
--
--
--
-----------------------------------------------------------------------------

module System.Information.CPU2 ( getCPULoad, getCPUInfo, getCPUTemp ) where

import Data.Maybe ( mapMaybe )
import Safe ( atMay, readDef, tailSafe )
import System.Information.StreamInfo ( getLoad, getParsedInfo )
import Control.Monad (liftM)

getCPULoad :: String -> IO [Double]
getCPULoad cpu = do
load <- getLoad 0.05 $ getCPUInfo cpu
case load of
l0:l1:l2:_ -> return [ l0 + l1, l2 ]
_ -> return []

getCPUTemp :: [String] -> IO [Int]
getCPUTemp cpus = do
let cpus' = map (\s -> [last s]) cpus
liftM concat $ mapM (\cpu -> getParsedInfo ("/sys/bus/platform/devices/coretemp.0/temp" ++ show ((read cpu::Int) + 1) ++ "_input") (\s -> [("temp", [(read s::Int) `div` 1000])]) "temp") cpus'
--TODO and suppoprt for more than 1 physical cpu.

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))


+ 0
- 27
vendor/taffybar/src/System/Information/DiskIO.hs View File

@@ -1,42 +0,0 @@
-----------------------------------------------------------------------------
--
--
-----------------------------------------------------------------------------

module System.Information.DiskIO ( getDiskTransfer ) where

import Data.Maybe ( mapMaybe )
import Safe ( atMay, headMay, readDef )
import System.Information.StreamInfo ( getParsedInfo, getTransfer )

getDiskTransfer :: String -> IO [Double]
getDiskTransfer disk = getTransfer 0.05 $ getDiskInfo disk

getDiskInfo :: String -> IO [Int]
getDiskInfo = getParsedInfo "/proc/diskstats" parse

parse :: String -> [(String, [Int])]
parse = mapMaybe tuplize . map (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])


+ 0
- 112
vendor/taffybar/src/System/Information/EWMHDesktopInfo.hs View File

@@ -1,149 +0,0 @@
-----------------------------------------------------------------------------
--
--
--
--
-----------------------------------------------------------------------------

module System.Information.EWMHDesktopInfo
( X11Window -- re-exported from X11DesktopInfo
, X11WindowHandle
, WorkspaceIdx(..)
, withDefaultCtx -- re-exported from X11DesktopInfo
, isWindowUrgent -- re-exported from X11DesktopInfo
, getCurrentWorkspace
, getVisibleWorkspaces
, getWorkspaceNames
, switchToWorkspace
, switchOneWorkspace
, getWindowTitle
, getWindowClass
, getActiveWindowTitle
, getWindows
, getWindowHandles
, getWorkspace
, focusWindow
) where

import Control.Applicative ((<$>))
import Data.Tuple (swap)
import Data.Maybe (listToMaybe, mapMaybe)
import System.Information.X11DesktopInfo

type X11WindowHandle = ((WorkspaceIdx, String, String), X11Window)

newtype WorkspaceIdx = WSIdx Int
deriving (Show, Read, Ord, Eq)

noFocus :: String
noFocus = "..."

getCurrentWorkspace :: X11Property WorkspaceIdx
getCurrentWorkspace = WSIdx <$> readAsInt Nothing "_NET_CURRENT_DESKTOP"

getVisibleWorkspaces :: X11Property [WorkspaceIdx]
getVisibleWorkspaces = do
vis <- getVisibleTags
allNames <- map swap <$> getWorkspaceNames
cur <- getCurrentWorkspace
return $ cur : mapMaybe (flip lookup allNames) vis

getWorkspaceNames :: X11Property [(WorkspaceIdx, String)]
getWorkspaceNames = go <$> readAsListOfString Nothing "_NET_DESKTOP_NAMES"
where go = zip [WSIdx i | i <- [0..]]

switchToWorkspace :: WorkspaceIdx -> X11Property ()
switchToWorkspace (WSIdx idx) = do
cmd <- getAtom "_NET_CURRENT_DESKTOP"
sendCommandEvent cmd (fromIntegral idx)

switchOneWorkspace :: Bool -> Int -> X11Property ()
switchOneWorkspace dir end = do
cur <- getCurrentWorkspace
switchToWorkspace $ if dir then getPrev cur end else getNext cur end

getPrev :: WorkspaceIdx -> Int -> WorkspaceIdx
getPrev (WSIdx idx) end
| idx > 0 = WSIdx $ idx-1
| otherwise = WSIdx end

getNext :: WorkspaceIdx -> Int -> WorkspaceIdx
getNext (WSIdx idx) end
| idx < end = WSIdx $ idx+1
| otherwise = WSIdx 0

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

getWindowClass :: X11Window -> X11Property String
getWindowClass window = readAsString (Just window) "WM_CLASS"

withActiveWindow :: (X11Window -> X11Property String) -> X11Property String
withActiveWindow getProp = do
awt <- readAsListOfWindow Nothing "_NET_ACTIVE_WINDOW"
let w = listToMaybe $ filter (>0) awt
maybe (return noFocus) getProp w

getActiveWindowTitle :: X11Property String
getActiveWindowTitle = withActiveWindow getWindowTitle

getWindows :: X11Property [X11Window]
getWindows = readAsListOfWindow Nothing "_NET_CLIENT_LIST"

getWindowHandles :: X11Property [X11WindowHandle]
getWindowHandles = do
windows <- getWindows
workspaces <- mapM getWorkspace windows
wtitles <- mapM getWindowTitle windows
wclasses <- mapM getWindowClass windows
return $ zip (zip3 workspaces wtitles wclasses) windows

getWorkspace :: X11Window -> X11Property WorkspaceIdx
getWorkspace window = WSIdx <$> readAsInt (Just window) "_NET_WM_DESKTOP"

focusWindow :: X11Window -> X11Property ()
focusWindow wh = do
cmd <- getAtom "_NET_ACTIVE_WINDOW"
sendWindowEvent cmd (fromIntegral wh)

+ 0
- 43
vendor/taffybar/src/System/Information/Memory.hs View File

@@ -1,43 +0,0 @@
module System.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
, memoryRest :: Double -- free + buffer + cache
, memoryUsed :: Double -- total - rest
, memoryUsedRatio :: Double -- used / total
}

emptyMemoryInfo :: MemoryInfo
emptyMemoryInfo = MemoryInfo 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 }
"Buffers:" -> memInfo { memoryBuffer = toMB size }
"Cached:" -> memInfo { memoryCache = 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
return m { memoryRest = rest
, memoryUsed = used
, memoryUsedRatio = usedRatio
}


+ 0
- 40
vendor/taffybar/src/System/Information/Network.hs View File

@@ -1,53 +0,0 @@
-----------------------------------------------------------------------------
--
--
--
-----------------------------------------------------------------------------

module System.Information.Network ( getNetInfo ) where

import Control.Applicative
import Data.Maybe ( mapMaybe )
import Safe ( atMay, initSafe, readDef )
import System.Information.StreamInfo ( getParsedInfo )

import Prelude

getNetInfo :: String -> IO (Maybe [Integer])
getNetInfo iface = do
isUp <- isInterfaceUp iface
case isUp of
True -> Just <$> getParsedInfo "/proc/net/dev" parse iface
False -> return Nothing

parse :: String -> [(String, [Integer])]
parse = mapMaybe tuplize . map words . drop 2 . lines

tuplize :: [String] -> Maybe (String, [Integer])
tuplize 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

isInterfaceUp :: String -> IO Bool
isInterfaceUp iface = do
state <- readFile $ "/sys/class/net/" ++ iface ++ "/operstate"
case state of
'u' : _ -> return True
_ -> return False

+ 0
- 62
vendor/taffybar/src/System/Information/StreamInfo.hs View File

@@ -1,90 +0,0 @@
--------------------------------------------------------------------------------
--
--
--
--------------------------------------------------------------------------------

module System.Information.StreamInfo
( getParsedInfo
, getLoad
, getAccLoad
, getTransfer
) where

import Control.Concurrent ( threadDelay )
import Data.IORef
import Data.Maybe ( fromMaybe )

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

toRatioList :: (Integral a, RealFloat b) => [a] -> [b]
toRatioList deltas = map truncVal ratios
where total = fromIntegral $ foldr (+) 0 deltas
ratios = map ((/total) . fromIntegral) deltas

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

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

getTransfer :: (Integral a, RealFloat b) => b -> IO [a] -> IO [b]
getTransfer interval action = do
deltas <- probe action interval
return $ map (truncVal . (/interval) . fromIntegral) deltas

getLoad :: (Integral a, RealFloat b) => b -> IO [a] -> IO [b]
getLoad interval action = do
deltas <- probe action interval
return $ toRatioList deltas

getAccLoad :: (Integral a, RealFloat b) => IORef [a] -> IO [a] -> IO [b]
getAccLoad sample action = do
deltas <- accProbe action sample
return $ toRatioList deltas


+ 0
- 156
vendor/taffybar/src/System/Information/X11DesktopInfo.hs View File

@@ -1,205 +0,0 @@
-----------------------------------------------------------------------------
--
--
--
--
-----------------------------------------------------------------------------

module System.Information.X11DesktopInfo
( X11Context
, X11Property
, X11Window
, withDefaultCtx
, readAsInt
, readAsString
, readAsListOfString
, readAsListOfWindow
, isWindowUrgent
, getVisibleTags
, getAtom
, eventLoop
, sendCommandEvent
, sendWindowEvent
) where

import Codec.Binary.UTF8.String as UTF8
import Control.Monad.Reader
import Data.Bits (testBit, (.|.))
import Data.List.Split (endBy)
import Data.Maybe (fromMaybe)
import Graphics.X11.Xlib
import Graphics.X11.Xlib.Extras

data X11Context = X11Context { contextDisplay :: Display, contextRoot :: Window }
type X11Property a = ReaderT X11Context IO a
type X11Window = Window
type PropertyFetcher a = Display -> Atom -> Window -> IO (Maybe [a])

withDefaultCtx :: X11Property a -> IO a
withDefaultCtx fun = do
ctx <- getDefaultCtx
res <- runReaderT fun ctx
closeDisplay (contextDisplay ctx)
return res

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)

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 []

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

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 []

isWindowUrgent :: X11Window -> X11Property Bool
isWindowUrgent window = do
hints <- fetchWindowHints window
return $ testBit (wmh_flags hints) urgencyHintBit

getVisibleTags :: X11Property [String]
getVisibleTags = return =<<
readAsListOfString Nothing "_XMONAD_VISIBLE_WORKSPACES"

getAtom :: String -> X11Property Atom
getAtom s = do
(X11Context d _) <- ask
atom <- liftIO $ internAtom d s False
return atom

eventLoop :: (Event -> IO ()) -> X11Property ()
eventLoop dispatch = do
(X11Context d w) <- ask
liftIO $ do
xSetErrorHandler
selectInput d w $ propertyChangeMask .|. substructureNotifyMask
allocaXEvent $ \e -> forever $ do
event <- nextEvent d e >> getEvent e
case event of
MapNotifyEvent _ _ _ _ _ window _ -> do
selectInput d window propertyChangeMask
_ -> return ()
dispatch event

sendCommandEvent :: Atom -> Atom -> X11Property ()
sendCommandEvent cmd arg = do
(X11Context dpy root) <- ask
sendCustomEvent dpy cmd arg root root

sendWindowEvent :: Atom -> X11Window -> X11Property ()
sendWindowEvent cmd win = do
(X11Context dpy root) <- ask
sendCustomEvent dpy cmd cmd root win

getDefaultCtx :: IO X11Context
getDefaultCtx = do
d <- openDisplay ""
w <- rootWindow d $ defaultScreen d
return $ X11Context d w

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
prop <- liftIO $ fetcher dpy atom (fromMaybe root window)
return prop

fetchWindowHints :: X11Window -> X11Property WMHints
fetchWindowHints window = do
(X11Context d _) <- ask
hints <- liftIO $ getWMHints d window
return hints

sendCustomEvent :: Display
-> Atom
-> Atom
-> X11Window
-> X11Window
-> X11Property ()
sendCustomEvent dpy cmd arg root win = do
liftIO $ allocaXEvent $ \e -> do
setEventType e clientMessage
setClientMessageEvent e win cmd 32 arg currentTime
sendEvent dpy root False structureNotifyMask e
sync dpy False

+ 0
- 296
vendor/taffybar/src/System/Taffybar.hs View File

@@ -1,305 +0,0 @@
module System.Taffybar (
-- * Detail
--
-- | This is a system status bar meant for use with window manager
-- 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:
--
-- > import System.Taffybar
-- > import System.Taffybar.Systray
-- > import System.Taffybar.XMonadLog
-- > import System.Taffybar.SimpleClock
-- > import System.Taffybar.Widgets.PollingGraph
-- > import System.Information.CPU
-- >
-- > 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 "<span fgcolor='orange'>%a %b %_d %H:%M</span>" 1
-- > log = xmonadLogNew
-- > tray = systrayNew
-- > cpu = pollingGraphNew cpuCfg 0.5 cpuCallback
-- > defaultTaffybar defaultTaffybarConfig { startWidgets = [ log ]
-- > , endWidgets = [ tray, clock, cpu ]
-- > }
--
-- This configuration creates a bar with four widgets. On the left is
-- the XMonad log. 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 [IO Widget] since the bar needs to construct them
-- after performing some GTK initialization.

-- * XMonad Integration (via DBus)
--
-- | The XMonadLog widget differs from its counterpart in xmobar: it
-- listens for updates over DBus instead of reading from stdin.
-- This makes it easy to restart Taffybar independently of XMonad.
-- XMonad does not come with a DBus logger, so here is an example of
-- how to make it work. Note: this requires the dbus-core (>0.9)
-- package, which is installed as a dependency of Taffybar.
--
-- > import XMonad.Hooks.DynamicLog
-- > import XMonad.Hooks.ManageDocks
-- > import DBus.Client
-- > import System.Taffybar.XMonadLog ( dbusLog )
-- >
-- > main = do
-- > client <- connectSession
-- > let pp = defaultPP
-- > xmonad defaultConfig { logHook = dbusLog client pp
-- > , manageHook = manageDocks
-- > }
--
-- The complexity is handled in the System.Tafftbar.XMonadLog
-- module. Note that manageDocks is required to have XMonad put
-- taffybar in the strut space that it reserves. If you have
-- problems with taffybar appearing almost fullscreen, check to
-- see if you have manageDocks in your manageHook.

-- ** A note about DBus:
-- |
-- * If you start xmonad 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 is in
-- @~\/.cabal\/share\/taffybar-\<version\>\/taffybar.rc@. You can
-- customize this theme by copying it to
-- @~\/.config\/taffybar\/taffybar.rc@. For an idea of the customizations you can make,
-- see <https://live.gnome.org/GnomeArt/Tutorials/GtkThemes>.
TaffybarConfig(..),
defaultTaffybar,
defaultTaffybarConfig,
Position(..),
taffybarMain
) where

import qualified Config.Dyre as Dyre
import qualified Config.Dyre.Params as Dyre
import Control.Monad ( when )
import Data.Maybe ( fromMaybe )
import System.Environment.XDG.BaseDir ( getUserConfigFile )
import System.FilePath ( (</>) )
import Graphics.UI.Gtk
import Safe ( atMay )
import System.Exit ( exitFailure )
import qualified System.IO as IO
import Text.Printf ( printf )

import Paths_taffybar ( getDataDir )
import System.Taffybar.StrutProperties

data Position = Top | Bottom
deriving (Show, Eq)


strutProperties :: Position -- ^ Bar position
-> Int -- ^ Bar height
-> Rectangle -- ^ Current monitor rectangle
-> [Rectangle] -- ^ All monitors
-> StrutProperties
strutProperties pos bh (Rectangle mX mY mW mH) monitors =
propertize pos sX sW sH
where sX = mX
sW = mW - 1
sH = case pos of Top -> bh + mY
Bottom -> bh + totalH - mY - mH
totalH = maximum $ map bottomY monitors
bottomY (Rectangle _ y _ h) = y + h
propertize p x w h = case p of
Top -> (0, 0, h, 0, 0, 0, 0, 0, x, x+w, 0, 0)
Bottom -> (0, 0, 0, h, 0, 0, 0, 0, 0, 0, x, x+w)

data TaffybarConfig =
TaffybarConfig { screenNumber :: Int -- ^ The screen number to run the bar on (default is almost always fine)
, monitorNumber :: Int -- ^ The xinerama/xrandr monitor number to put the bar on (default: 0)
, barHeight :: Int -- ^ Number of pixels to reserve for the bar (default: 25 pixels)
, barPosition :: Position -- ^ The position of the bar on the screen (default: Top)
, widgetSpacing :: Int -- ^ The number of pixels between widgets
, errorMsg :: Maybe String -- ^ Used by the application
, startWidgets :: [IO Widget] -- ^ Widgets that are packed in order at the left end of the bar
, endWidgets :: [IO Widget] -- ^ Widgets that are packed from right-to-left in the bar
}

defaultTaffybarConfig :: TaffybarConfig
defaultTaffybarConfig =
TaffybarConfig { screenNumber = 0
, monitorNumber = 0
, barHeight = 25
, barPosition = Top
, widgetSpacing = 10
, errorMsg = Nothing
, startWidgets = []
, endWidgets = []
}

showError :: TaffybarConfig -> String -> TaffybarConfig
showError cfg msg = cfg { errorMsg = Just msg }

defaultParams :: Dyre.Params TaffybarConfig
defaultParams = Dyre.defaultParams { Dyre.projectName = "taffybar"
, Dyre.realMain = realMain
, Dyre.showError = showError
, Dyre.ghcOpts = ["-threaded", "-rtsopts"]
, Dyre.rtsOptsHandling = Dyre.RTSAppend ["-I0", "-V0"]
}

defaultTaffybar :: TaffybarConfig -> IO ()
defaultTaffybar = Dyre.wrapMain defaultParams

realMain :: TaffybarConfig -> IO ()
realMain cfg = do
case errorMsg cfg of
Nothing -> taffybarMain cfg
Just err -> do
IO.hPutStrLn IO.stderr ("Error: " ++ err)
exitFailure

getDefaultConfigFile :: String -> IO FilePath
getDefaultConfigFile name = do
dataDir <- getDataDir
return (dataDir </> name)

setTaffybarSize :: TaffybarConfig -> Window -> IO ()
setTaffybarSize cfg window = do
screen <- windowGetScreen window
nmonitors <- screenGetNMonitors screen
allMonitorSizes <- mapM (screenGetMonitorGeometry screen) [0 .. (nmonitors - 1)]

when (monitorNumber cfg >= nmonitors) $ do
IO.hPutStrLn IO.stderr $ printf "Monitor %d is not available in the selected screen" (monitorNumber cfg)

let monitorSize = fromMaybe (allMonitorSizes !! 0) $ do
allMonitorSizes `atMay` monitorNumber cfg

let Rectangle x y w h = monitorSize
yoff = case barPosition cfg of
Top -> 0
Bottom -> h - barHeight cfg
windowMove window x (y + yoff)

-- Set up the window size using fixed min and max sizes. This
-- prevents the contained horizontal box from affecting the window
-- size.
windowSetGeometryHints window
(Nothing :: Maybe Widget)
(Just (w, barHeight cfg)) -- Min size.
(Just (w, barHeight cfg)) -- Max size.
Nothing
Nothing
Nothing

let setStrutProps = setStrutProperties window
$ strutProperties (barPosition cfg)
(barHeight cfg)
monitorSize
allMonitorSizes

winRealized <- widgetGetRealized window
if winRealized
then setStrutProps
else onRealize window setStrutProps >> return ()

taffybarMain :: TaffybarConfig -> IO ()
taffybarMain cfg = do

_ <- initGUI

-- Load default and user gtk resources
defaultGtkConfig <- getDefaultConfigFile "taffybar.rc"
userGtkConfig <- getUserConfigFile "taffybar" "taffybar.rc"
rcParse defaultGtkConfig
rcParse userGtkConfig

Just disp <- displayGetDefault
nscreens <- displayGetNScreens disp
screen <- case screenNumber cfg < nscreens of
False -> error $ printf "Screen %d is not available in the default display" (screenNumber cfg)
True -> displayGetScreen disp (screenNumber cfg)

window <- windowNew
widgetSetName window "Taffybar"
windowSetTypeHint window WindowTypeHintDock
windowSetScreen window screen
setTaffybarSize cfg window

-- Reset the size of the Taffybar window if the monitor setup has
-- changed, e.g., after a laptop user has attached an external
-- monitor.
_ <- on screen screenMonitorsChanged (setTaffybarSize cfg window)

box <- hBoxNew False $ widgetSpacing cfg
containerAdd window box

mapM_ (\io -> do
wid <- io
widgetSetSizeRequest wid (-1) (barHeight cfg)
boxPackStart box wid PackNatural 0) (startWidgets cfg)
mapM_ (\io -> do
wid <- io
widgetSetSizeRequest wid (-1) (barHeight cfg)
boxPackEnd box wid PackNatural 0) (endWidgets cfg)

widgetShow window
widgetShow box
mainGUI
return ()

+ 0
- 117
vendor/taffybar/src/System/Taffybar/Battery.hs View File

@@ -1,137 +0,0 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
--
module System.Taffybar.Battery (
batteryBarNew,
textBatteryNew,
defaultBatteryConfig
) where

import qualified Control.Exception.Enclosed as E
import Data.Int ( Int64 )
import Data.IORef
import Graphics.UI.Gtk
import qualified System.IO as IO
import Text.Printf ( printf )
import Text.StringTemplate

import System.Information.Battery
import System.Taffybar.Widgets.PollingBar
import System.Taffybar.Widgets.PollingLabel

safeGetBatteryInfo :: IORef BatteryContext -> IO (Maybe BatteryInfo)
safeGetBatteryInfo mv = do
ctxt <- readIORef mv
E.catchAny (getBatteryInfo ctxt) $ \_ -> reconnect
where
reconnect = do
mctxt <- batteryContextNew
case mctxt of
Nothing -> IO.hPutStrLn IO.stderr "Could not reconnect to UPower"
Just ctxt -> writeIORef mv ctxt
return Nothing

battInfo :: IORef BatteryContext -> String -> IO String
battInfo r fmt = do
minfo <- safeGetBatteryInfo r
case minfo of
Nothing -> return ""
Just info -> do
let battPctNum :: Int
battPctNum = floor (batteryPercentage info)
formatTime :: Int64 -> String
formatTime seconds =
let minutes = seconds `div` 60
hours = minutes `div` 60
minutes' = minutes `mod` 60
in printf "%02d:%02d" hours minutes'

battTime :: String
battTime = case (batteryState info) of
BatteryStateCharging -> (formatTime $ batteryTimeToFull info)
BatteryStateDischarging -> (formatTime $ batteryTimeToEmpty info)
_ -> "-"

tpl = newSTMP fmt
tpl' = setManyAttrib [ ("percentage", show battPctNum)
, ("time", battTime)
] tpl
return $ render tpl'

textBatteryNew :: String -- ^ Display format
-> Double -- ^ Poll period in seconds
-> IO Widget
textBatteryNew fmt pollSeconds = do
battCtxt <- batteryContextNew
case battCtxt of
Nothing -> do
let lbl :: Maybe String
lbl = Just "No battery"
labelNew lbl >>= return . toWidget
Just ctxt -> do
r <- newIORef ctxt
l <- pollingLabelNew "" pollSeconds (battInfo r fmt)
widgetShowAll l
return l

battPct :: IORef BatteryContext -> IO Double
battPct r = do
minfo <- safeGetBatteryInfo r
case minfo of
Nothing -> return 0
Just info -> return (batteryPercentage info / 100)

--
defaultBatteryConfig :: BarConfig
defaultBatteryConfig =
defaultBarConfig colorFunc
where
colorFunc pct
| pct < 0.1 = (1, 0, 0)
| pct < 0.9 = (0.5, 0.5, 0.5)
| otherwise = (0, 1, 0)

batteryBarNew :: BarConfig -- ^ Configuration options for the bar display
-> Double -- ^ Polling period in seconds
-> IO Widget
batteryBarNew battCfg pollSeconds = do
battCtxt <- batteryContextNew
case battCtxt of
Nothing -> do
let lbl :: Maybe String
lbl = Just "No battery"
labelNew lbl >>= return . toWidget
Just ctxt -> do
-- This is currently pretty inefficient - each poll period it
-- queries the battery twice (once for the label and once for
-- the bar).
--
-- Converting it to combine the two shouldn't be hard.
b <- hBoxNew False 1
txt <- textBatteryNew "$percentage$%" pollSeconds
r <- newIORef ctxt
bar <- pollingBarNew battCfg pollSeconds (battPct r)
boxPackStart b bar PackNatural 0
boxPackStart b txt PackNatural 0
widgetShowAll b
return (toWidget b)

+ 0
- 28
vendor/taffybar/src/System/Taffybar/CPUMonitor.hs View File

@@ -1,40 +0,0 @@
--------------------------------------------------------------------------------
--
--
--
--------------------------------------------------------------------------------
module System.Taffybar.CPUMonitor where

import Data.IORef
import Graphics.UI.Gtk
import System.Information.CPU2 (getCPUInfo)
import System.Information.StreamInfo (getAccLoad)
import System.Taffybar.Widgets.PollingGraph

cpuMonitorNew :: GraphConfig -- ^ Configuration data for the Graph.
-> Double -- ^ Polling period (in seconds).
-> String -- ^ Name of the core to watch (e.g. \"cpu\", \"cpu0\").
-> IO Widget
cpuMonitorNew cfg interval cpu = 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 []

+ 0
- 36
vendor/taffybar/src/System/Taffybar/CommandRunner.hs View File

@@ -1,48 +0,0 @@
--------------------------------------------------------------------------------
--
--
--
--------------------------------------------------------------------------------

module System.Taffybar.CommandRunner ( commandRunnerNew ) where

import qualified Graphics.UI.Gtk as Gtk
import System.Taffybar.Pager (colorize)
import System.Taffybar.Widgets.PollingLabel

import Control.Monad
import System.Exit (ExitCode (..))
import qualified System.IO as IO
import qualified System.Process as P

commandRunnerNew :: Double -- ^ Polling period (in seconds).
-> String -- ^ Command to execute. Should be in $PATH or an absolute path
-> [String] -- ^ Command argument. May be @[]@
-> String -- ^ If command fails this will be displayed.
-> String -- ^ Output color
-> IO Gtk.Widget
commandRunnerNew interval cmd args defaultOutput color = do
label <- pollingLabelNew "" interval $ runCommand cmd args defaultOutput color
Gtk.widgetShowAll label
return $ Gtk.toWidget label

runCommand :: FilePath -> [String] -> String -> String -> IO String
runCommand cmd args defaultOutput color = do
(ecode, stdout, stderr) <- P.readProcessWithExitCode cmd args ""
unless (null stderr) $ do
IO.hPutStrLn IO.stderr stderr
return $ colorize color "" $ case ecode of
ExitSuccess -> stdout
ExitFailure _ -> defaultOutput

+ 0
- 24
vendor/taffybar/src/System/Taffybar/DiskIOMonitor.hs View File

@@ -1,37 +0,0 @@
--------------------------------------------------------------------------------
--
--
--
--------------------------------------------------------------------------------

module System.Taffybar.DiskIOMonitor ( dioMonitorNew ) where

import qualified Graphics.UI.Gtk as Gtk
import System.Information.DiskIO ( getDiskTransfer )
import System.Taffybar.Widgets.PollingGraph ( GraphConfig, pollingGraphNew )

dioMonitorNew :: GraphConfig -- ^ Configuration data for the Graph.
-> Double -- ^ Polling period (in seconds).
-> String -- ^ Name of the disk or partition to watch (e.g. \"sda\", \"sdb1\").
-> IO 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

+ 0
- 25
vendor/taffybar/src/System/Taffybar/FSMonitor.hs View File

@@ -1,38 +0,0 @@
-----------------------------------------------------------------------------
--
--
--
-----------------------------------------------------------------------------

module System.Taffybar.FSMonitor ( fsMonitorNew ) where

import qualified Graphics.UI.Gtk as Gtk
import System.Process ( readProcess )
import System.Taffybar.Widgets.PollingLabel ( pollingLabelNew )

fsMonitorNew :: Double -- ^ Polling interval (in seconds, e.g. 500)
-> [String] -- ^ Names of the partitions to monitor (e.g. [\"\/\", \"\/home\"])
-> IO Gtk.Widget
fsMonitorNew interval fsList = do
label <- pollingLabelNew "" interval $ showFSInfo fsList
Gtk.widgetShowAll label
return $ Gtk.toWidget label

showFSInfo :: [String] -> IO String
showFSInfo fsList = do
fsOut <- readProcess "df" (["-kP"] ++ fsList) ""
let fss = map (take 2 . reverse . words) $ drop 1 $ lines fsOut
return $ unwords $ map ((\s -> "[" ++ s ++ "]") . unwords) fss

+ 0
- 285
vendor/taffybar/src/System/Taffybar/FreedesktopNotifications.hs View File

@@ -1,318 +0,0 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
--
module System.Taffybar.FreedesktopNotifications (
-- * Types
Notification(..),
NotificationConfig(..),
-- * Constructor
notifyAreaNew,
defaultNotificationConfig
) where

import Control.Concurrent
import Control.Concurrent.STM
import Control.Monad ( forever )
import Control.Monad.Trans ( liftIO )
import Data.Int ( Int32 )
import Data.Map ( Map )
import Data.Monoid ( mconcat )
import qualified Data.Sequence as S
import Data.Sequence ( Seq, (|>), viewl, ViewL(..) )
import Data.Text ( Text )
import qualified Data.Text as T
import Data.Word ( Word32 )
import DBus
import DBus.Client
import Graphics.UI.Gtk hiding ( Variant )

data Notification = Notification { noteAppName :: Text
, noteReplaceId :: Word32
, noteSummary :: Text
, noteBody :: Text
, noteExpireTimeout :: Int32
, noteId :: Word32
}
deriving (Show, Eq)

data NotifyState = NotifyState { noteWidget :: Label
, noteContainer :: Widget
, noteConfig :: NotificationConfig
, noteQueue :: TVar (Seq Notification)
-- ^ The queue of active (but not yet
-- displayed) notifications
, noteIdSource :: TVar Word32
-- ^ A source of new notification ids
, noteCurrent :: TVar (Maybe Notification)
-- ^ The current note being displayed
, noteChan :: Chan ()
-- ^ Wakes up the GUI update thread
}

initialNoteState :: Widget -> Label -> NotificationConfig -> IO NotifyState
initialNoteState wrapper l cfg = do
m <- newTVarIO 1
q <- newTVarIO S.empty
c <- newTVarIO Nothing
ch <- newChan
return NotifyState { noteQueue = q
, noteIdSource = m
, noteWidget = l
, noteContainer = wrapper
, noteCurrent = c
, noteConfig = cfg
, noteChan = ch
}

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"]

nextNotification :: NotifyState -> STM ()
nextNotification s = do
q <- readTVar (noteQueue s)
case viewl q of
EmptyL -> do
writeTVar (noteCurrent s) Nothing
next :< rest -> do
writeTVar (noteQueue s) rest
writeTVar (noteCurrent s) (Just next)

closeNotification :: NotifyState -> Word32 -> IO ()
closeNotification istate nid = do
atomically $ do
modifyTVar' (noteQueue istate) removeNote
curNote <- readTVar (noteCurrent istate)
case curNote of
Nothing -> return ()
Just cnote
| noteId cnote /= nid -> return ()
| otherwise ->
-- in this case, the note was current so we take the next,
-- if any
nextNotification istate
wakeupDisplayThread istate
where
removeNote = S.filter (\n -> noteId n /= nid)

formatMessage :: NotifyState -> Notification -> String
formatMessage s = fmt
where
fmt = notificationFormatter $ noteConfig s

--
--
--
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 istate appName replaceId _ summary body _ _ timeout = do
nid <- atomically $ do
tid <- readTVar idsrc
modifyTVar' idsrc (+1)
return tid
let realId = if replaceId == 0 then fromIntegral nid else replaceId
n = Notification { noteAppName = appName
, noteReplaceId = replaceId
, noteSummary = escapeText summary
, noteBody = escapeText body
, noteExpireTimeout = tout
, noteId = realId
}
-- If we are replacing an existing note, atomically do the swap in
-- the note queue and then make this the new current if the queue is
-- empty OR if the current has this id.
dn <- atomically $ do
modifyTVar' (noteQueue istate) (replaceNote n)
cnote <- readTVar (noteCurrent istate)
case cnote of
Nothing -> do
writeTVar (noteCurrent istate) (Just n)
return (Just n)
Just curNote
| noteId curNote == realId -> do
writeTVar (noteCurrent istate) (Just n)
return (Just n)
| otherwise -> do
modifyTVar' (noteQueue istate) (|>n)
return Nothing
-- This is a little gross - if we added the new notification to the
-- queue, we can't call displayNote on it because that will
-- obliterate the current active notification.
case dn of
-- take no action; timeout threads will handle it
Nothing -> return ()
Just _ -> wakeupDisplayThread istate
return realId
where
replaceNote newNote = fmap (\n -> if noteId n == noteReplaceId newNote then newNote else n)
idsrc = noteIdSource istate
escapeText = T.pack . escapeMarkup . T.unpack
maxtout = fromIntegral $ notificationMaxTimeout (noteConfig istate)
tout = case timeout of
0 -> maxtout
(-1) -> maxtout
_ -> min maxtout timeout

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"
[ autoMethod "org.freedesktop.Notifications" "GetServerInformation" getServerInformation
, autoMethod "org.freedesktop.Notifications" "GetCapabilities" getCapabilities
, autoMethod "org.freedesktop.Notifications" "CloseNotification" onCloseNote
, autoMethod "org.freedesktop.Notifications" "Notify" onNote
]

wakeupDisplayThread :: NotifyState -> IO ()
wakeupDisplayThread s = writeChan (noteChan s) ()

displayThread :: NotifyState -> IO ()
displayThread s = forever $ do
_ <- readChan (noteChan s)
cur <- atomically $ readTVar (noteCurrent s)
case cur of
Nothing -> postGUIAsync (widgetHideAll (noteContainer s))
Just n -> postGUIAsync $ do
labelSetMarkup (noteWidget s) (formatMessage s n)
widgetShowAll (noteContainer s)
startTimeoutThread s n

startTimeoutThread :: NotifyState -> Notification -> IO ()
startTimeoutThread s n = do
_ <- forkIO $ do
let seconds = noteExpireTimeout n
threadDelay (fromIntegral seconds * 1000000)
atomically $ do
curNote <- readTVar (noteCurrent s)
case curNote of
Nothing -> return ()
Just cnote
| cnote /= n -> return ()
| otherwise ->
-- The note was not invalidated or changed since the timeout
-- began, so we replace it with the next (if any)
nextNotification s
wakeupDisplayThread s
return ()

data NotificationConfig =
NotificationConfig { notificationMaxTimeout :: Int -- ^ Maximum time that a notification will be displayed (in seconds). Default: 10
, notificationMaxLength :: Int -- ^ Maximum length displayed, in characters. Default: 50
, notificationFormatter :: Notification -> String -- ^ Function used to format notifications
}

defaultFormatter :: Notification -> String
defaultFormatter note = msg