Browse Source

Get everything building again after 2 years of neglect

master
Peter J. Jones 1 month 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 @@
1 1
 /dist
2
-/.stack-work
3
-/build/.stack-work
4
-/vendor/taffybar/.stack-work
5
-/dist-newstyle
6
-/cabal.project.local
2
+/result

+ 0
- 18
.gitmodules View File

@@ -1,18 +0,0 @@
1
-[submodule "vendor/xmonad"]
2
-	path = vendor/xmonad
3
-	url = https://github.com/pjones/xmonad.git
4
-[submodule "vendor/xmonad-contrib"]
5
-	path = vendor/xmonad-contrib
6
-	url = https://github.com/pjones/xmonad-contrib.git
7
-[submodule "vendor/playlists"]
8
-	path = vendor/playlists
9
-	url = git://git.devalot.com/playlists
10
-[submodule "vendor/playlists-http"]
11
-	path = vendor/playlists-http
12
-	url = git://git.devalot.com/playlists-http
13
-[submodule "vendor/x11"]
14
-	path = vendor/x11
15
-	url = https://github.com/xmonad/X11.git
16
-[submodule "vendor/x11-xft"]
17
-	path = vendor/x11-xft
18
-	url = https://github.com/csstaub/X11-xft.git

+ 0
- 8
cabal.project View File

@@ -1,8 +0,0 @@
1
-packages: ./
2
-          vendor/playlists
3
-          vendor/playlists-http
4
-          vendor/x11/
5
-          vendor/x11-xft/
6
-          vendor/xmonad/
7
-          vendor/xmonad-contrib
8
-          vendor/taffybar

+ 16
- 0
default.nix View File

@@ -0,0 +1,16 @@
1
+{ pkgs ? import <nixpkgs> {}
2
+}:
3
+
4
+let
5
+  # Use my copy of some packages:
6
+  overrides = self: super: with pkgs.haskell.lib; {
7
+    xmonad = import ./nix/xmonad.nix { inherit pkgs; };
8
+    xmonad-contrib = import ./nix/xmonad-contrib.nix { inherit pkgs; };
9
+  };
10
+
11
+  # Apply the overrides from above:
12
+  haskell = pkgs.haskellPackages.override (orig: {
13
+    overrides = pkgs.lib.composeExtensions
14
+      (orig.overrides or (_: _: {})) overrides; });
15
+
16
+in haskell.callPackage ./xmonadrc.nix { }

+ 0
- 24
etc/taffybar.gtk View File

@@ -1,24 +0,0 @@
1
-gtk_color_scheme = "black:#191919\nwhite:#839496\ngreen:#859900\nred:#dc322f"
2
-
3
-style "default" {
4
-  font_name    = "Monospace 8"
5
-  bg[NORMAL]   = @black
6
-  fg[NORMAL]   = @white
7
-  text[NORMAL] = @white
8
-  fg[PRELIGHT] = @green
9
-  bg[PRELIGHT] = @black
10
-}
11
-
12
-style "active-window" = "default" {
13
-  fg[NORMAL] = @green
14
-}
15
-
16
-style "notification-button" = "default" {
17
-  text[NORMAL] = @red
18
-  fg[NORMAL]   = @red
19
-}
20
-
21
-widget "Taffybar*" style "default"
22
-widget "Taffybar*WindowSwitcher*label" style "active-window"
23
-widget "*NotificationCloseButton" style "notification-button"
24
-

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

@@ -0,0 +1,18 @@
1
+{ mkDerivation, base, bytestring, containers, directory
2
+, extensible-exceptions, filepath, mtl, old-locale, old-time
3
+, process, random, semigroups, stdenv, unix, utf8-string, X11
4
+, X11-xft, xmonad
5
+}:
6
+mkDerivation {
7
+  pname = "xmonad-contrib";
8
+  version = "0.15";
9
+  src = ./.;
10
+  libraryHaskellDepends = [
11
+    base bytestring containers directory extensible-exceptions filepath
12
+    mtl old-locale old-time process random semigroups unix utf8-string
13
+    X11 X11-xft xmonad
14
+  ];
15
+  homepage = "http://xmonad.org/";
16
+  description = "Third party extensions for xmonad";
17
+  license = stdenv.lib.licenses.bsd3;
18
+}

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

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

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

@@ -0,0 +1,13 @@
1
+# Pull in xmonad-contrib from my mirror:
2
+{ pkgs ? import <nixpkgs> { }
3
+}:
4
+
5
+with pkgs.lib;
6
+
7
+let
8
+  src = pkgs.fetchgit (removeAttrs (importJSON ./xmonad-contrib.json) ["date"]);
9
+  haskell = pkgs.haskellPackages;
10
+  withSrc = args: haskell.mkDerivation (args // { inherit src; });
11
+in
12
+
13
+haskell.callPackage ./xmonad-contrib.cabal.nix { mkDerivation = withSrc; }

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

@@ -0,0 +1,26 @@
1
+{ mkDerivation, base, containers, data-default, directory
2
+, extensible-exceptions, filepath, mtl, process, QuickCheck
3
+, setlocale, stdenv, unix, utf8-string, X11
4
+}:
5
+mkDerivation {
6
+  pname = "xmonad";
7
+  version = "0.15";
8
+  src = ./.;
9
+  isLibrary = true;
10
+  isExecutable = true;
11
+  libraryHaskellDepends = [
12
+    base containers data-default directory extensible-exceptions
13
+    filepath mtl process setlocale unix utf8-string X11
14
+  ];
15
+  executableHaskellDepends = [ base mtl unix X11 ];
16
+  testHaskellDepends = [
17
+    base containers extensible-exceptions QuickCheck X11
18
+  ];
19
+  postInstall = ''
20
+    install -D man/xmonad.1 $doc/share/man/man1/xmonad.1
21
+    install -D man/xmonad.hs $doc/share/doc/$name/sample-xmonad.hs
22
+  '';
23
+  homepage = "http://xmonad.org";
24
+  description = "A tiling window manager";
25
+  license = stdenv.lib.licenses.bsd3;
26
+}

+ 7
- 0
nix/xmonad.json View File

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

+ 13
- 0
nix/xmonad.nix View File

@@ -0,0 +1,13 @@
1
+# Pull in xmonad from my mirror:
2
+{ pkgs ? import <nixpkgs> { }
3
+}:
4
+
5
+with pkgs.lib;
6
+
7
+let
8
+  src = pkgs.fetchgit (removeAttrs (importJSON ./xmonad.json) ["date"]);
9
+  haskell = pkgs.haskellPackages;
10
+  withSrc = args: haskell.mkDerivation (args // { inherit src; });
11
+in
12
+
13
+haskell.callPackage ./xmonad.cabal.nix { mkDerivation = withSrc; }

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

@@ -1,36 +0,0 @@
1
-#!/bin/sh -eu
2
-
3
-################################################################################
4
-# Configure Git remote repositories.
5
-
6
-################################################################################
7
-set_remote() {
8
-  name=$1
9
-  url=$2
10
-
11
-  if git remote get-url "$name" > /dev/null 2>&1; then
12
-    git remote set-url "$name" "$url"
13
-  else
14
-    git remote add "$name" "$url"
15
-  fi
16
-}
17
-
18
-################################################################################
19
-# xmonad
20
-( cd vendor/xmonad
21
-  set_remote github   https://github.com/pjones/xmonad.git
22
-  set_remote upstream https://github.com/xmonad/xmonad.git
23
-)
24
-
25
-################################################################################
26
-# xmonad-contrib
27
-( cd vendor/xmonad-contrib
28
-  set_remote github   https://github.com/pjones/xmonad-contrib.git
29
-  set_remote upstream https://github.com/xmonad/xmonad-contrib.git
30
-)
31
-
32
-################################################################################
33
-# x11
34
-( cd vendor/x11
35
-  set_remote upstream https://github.com/xmonad/X11.git
36
-)

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

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

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

@@ -22,16 +22,13 @@ import XMonad.Layout.LayoutCombinators
22 22
 import XMonad.Layout.LayoutModifier
23 23
 import XMonad.Layout.Master (mastered)
24 24
 import XMonad.Layout.NoBorders (noBorders)
25
-import XMonad.Layout.NoFrillsDecoration
26 25
 import XMonad.Layout.Reflect (reflectHoriz, reflectVert)
27 26
 import XMonad.Layout.Renamed (Rename(..), renamed)
28 27
 import XMonad.Layout.ResizableTile (ResizableTall(..))
29
-import XMonad.Layout.Spacing (spacing)
30 28
 import XMonad.Layout.ThreeColumns (ThreeCol(..))
31 29
 import XMonad.Layout.ToggleLayouts (toggleLayouts)
32 30
 import XMonad.Layout.TwoPane (TwoPane(..))
33 31
 import XMonad.Local.Prompt (aListCompFunc)
34
-import XMonad.Local.Theme (topBarTheme)
35 32
 import XMonad.Prompt
36 33
 import XMonad.Util.Types (Direction2D(..))
37 34
 
@@ -41,10 +38,9 @@ import XMonad.Util.Types (Direction2D(..))
41 38
 layoutHook =
42 39
     toggleLayouts
43 40
       (noBorders fullscreen)
44
-      (addDeco $ addSpace allLays)
41
+      allLays
45 42
   where
46
-    addDeco  = renamed [CutWordsLeft 1] . noFrillsDeco shrinkText topBarTheme
47
-    addSpace = renamed [CutWordsLeft 2] . spacing 4
43
+    -- addSpace = renamed [CutWordsLeft 2] . spacingRaw 4
48 44
 
49 45
     fullscreen :: ModifiedLayout Rename (ModifiedLayout Gaps Full) Window
50 46
     fullscreen = renamed [Replace "Full"] (gaps (uniformGaps 60) Full)

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

@@ -1,3 +1,4 @@
1
+{-# LANGUAGE FlexibleContexts  #-}
1 2
 {-# LANGUAGE OverloadedStrings #-}
2 3
 
3 4
 --------------------------------------------------------------------------------
@@ -15,10 +16,9 @@ module XMonad.Local.Music (radioPrompt) where
15 16
 --------------------------------------------------------------------------------
16 17
 import Control.Exception
17 18
 import Control.Monad (when, void)
18
-import Control.Monad.IO.Class (liftIO)
19
+import Control.Monad.Except (MonadError(..), runExceptT, liftEither)
20
+import Control.Monad.IO.Class (MonadIO, liftIO)
19 21
 import Control.Monad.Random (evalRandIO, uniform)
20
-import Control.Monad.Trans.Class (lift)
21
-import Control.Monad.Trans.Either
22 22
 import qualified Data.ByteString as ByteString
23 23
 import Data.List (find)
24 24
 import Data.Maybe (mapMaybe)
@@ -78,20 +78,23 @@ radioPrompt c = do
78 78
 
79 79
 --------------------------------------------------------------------------------
80 80
 playStream :: Playlist -> String -> X ()
81
-playStream playlist title = void $ runEitherT $ do
82
-    url <- findTrack (Text.pack title)
83
-    manager <- liftIO (newManager defaultManagerSettings)
84
-    streams <- hoistEither =<< download (env manager) url
85
-    track   <- pickTrack streams
86
-    lift (playURL $ trackURL track)
81
+playStream playlist title = do
82
+    track <- runExceptT $ do
83
+      url <- findTrack (Text.pack title)
84
+      manager <- liftIO (newManager defaultManagerSettings)
85
+      streams <- liftEither =<< download (env manager) url
86
+      pickTrack streams
87
+    case track of
88
+      Left _  -> return ()
89
+      Right t -> playURL (trackURL t)
87 90
   where
88
-    findTrack :: Text -> EitherT Error X Text
91
+    findTrack :: (MonadError Error m) => Text -> m Text
89 92
     findTrack name =
90 93
       case find (\t -> trackTitle t == Just name) playlist of
91
-        Nothing    -> left (InvalidURL name)
94
+        Nothing    -> throwError (InvalidURL name)
92 95
         Just track -> return (trackURL track)
93 96
 
94
-    pickTrack :: Playlist -> EitherT Error X Track
97
+    pickTrack :: (MonadIO m) => Playlist -> m Track
95 98
     pickTrack = liftIO . evalRandIO . uniform
96 99
 
97 100
     env :: Manager -> Environment

+ 0
- 1
vendor/playlists

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

+ 0
- 1
vendor/playlists-http

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

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

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

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

@@ -1,74 +0,0 @@
1
-# This file has been generated -- see https://github.com/hvr/multi-ghc-travis
2
-language: c
3
-sudo: false
4
-
5
-cache:
6
-  directories:
7
-    - $HOME/.cabsnap
8
-    - $HOME/.cabal/packages
9
-
10
-before_cache:
11
-  - rm -fv $HOME/.cabal/packages/hackage.haskell.org/build-reports.log
12
-  - rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.tar
13
-
14
-matrix:
15
-  include:
16
-    - env: CABALVER=1.18 GHCVER=7.6.3
17
-      compiler: ": #GHC 7.6.3"
18
-      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]}}
19
-    - env: CABALVER=1.18 GHCVER=7.8.4
20
-      compiler: ": #GHC 7.8.4"
21
-      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]}}
22
-    - env: CABALVER=1.22 GHCVER=7.10.3
23
-      compiler: ": #GHC 7.10.3"
24
-      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]}}
25
-
26
-before_install:
27
- - unset CC
28
- - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:/opt/alex/3.1.4/bin:/opt/happy/1.19.5/bin:$PATH
29
-
30
-install:
31
- - cabal --version
32
- - echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]"
33
- - if [ -f $HOME/.cabal/packages/hackage.haskell.org/00-index.tar.gz ];
34
-   then
35
-     zcat $HOME/.cabal/packages/hackage.haskell.org/00-index.tar.gz >
36
-          $HOME/.cabal/packages/hackage.haskell.org/00-index.tar;
37
-   fi
38
- - travis_retry cabal update -v
39
- - sed -i 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config
40
- - cabal install gtk2hs-buildtools
41
- - cabal install --constraint='gtk >= 0.14' --constraint='cairo >= 0.13.1.1' --only-dependencies --enable-tests --enable-benchmarks --dry -v > installplan.txt
42
- - sed -i -e '1,/^Resolving /d' installplan.txt; cat installplan.txt
43
-# check whether current requested install-plan matches cached package-db snapshot
44
- - if diff -u installplan.txt $HOME/.cabsnap/installplan.txt;
45
-   then
46
-     echo "cabal build-cache HIT";
47
-     rm -rfv .ghc;
48
-     cp -a $HOME/.cabsnap/ghc $HOME/.ghc;
49
-     cp -a $HOME/.cabsnap/lib $HOME/.cabsnap/share $HOME/.cabsnap/bin $HOME/.cabal/;
50
-   else
51
-     echo "cabal build-cache MISS";
52
-     rm -rf $HOME/.cabsnap;
53
-     mkdir -p $HOME/.ghc $HOME/.cabal/lib $HOME/.cabal/share $HOME/.cabal/bin;
54
-     cabal install --only-dependencies --enable-tests --enable-benchmarks --force-reinstalls;
55
-   fi
56
-
57
-# snapshot package-db on cache miss
58
- - if [ ! -d $HOME/.cabsnap ];
59
-   then
60
-      echo "snapshotting package-db to build-cache";
61
-      mkdir $HOME/.cabsnap;
62
-      cp -a $HOME/.ghc $HOME/.cabsnap/ghc;
63
-      cp -a $HOME/.cabal/lib $HOME/.cabal/share $HOME/.cabal/bin installplan.txt $HOME/.cabsnap/;
64
-   fi
65
-
66
-# Here starts the actual work to be performed for the package under test;
67
-# any command which exits with a non-zero exit code causes the build to fail.
68
-script:
69
- - if [ -f configure.ac ]; then autoreconf -i; fi
70
- - cabal configure --enable-tests --enable-benchmarks -v2  # -v2 provides useful information for debugging
71
- - cabal build   # this builds all libraries and executables (including tests/benchmarks)
72
- - cabal test
73
-
74
-# EOF

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

@@ -1,87 +0,0 @@
1
-# 0.4.6
2
-
3
- * Fix a longstanding bug in loading .rc files (Peder Stray)
4
- * Add support for scrolling in the workspace switcher (Saksham Sharma)
5
- * Improve default formatting of empty workspaces in the pager (Saksham Sharma)
6
- * Relax gtk version bounds
7
-
8
-# 0.4.5
9
-
10
- * GHC 7.10 compat
11
-
12
-# 0.4.4
13
-
14
- * Fix compilation with gtk 0.13.1
15
-
16
-# 0.4.3
17
-
18
- * Try again to fix the network dependency
19
-
20
-# 0.4.2
21
-
22
- * Expand the version range for time
23
- * Depend on network-uri instead of network
24
-
25
-# 0.4.1
26
-
27
- * Make the clock react to time zone changes
28
-
29
-# 0.4.0
30
-
31
-## Features
32
-
33
- * Resize the bar when the screen configuration changes (Robert Helgesson)
34
- * Support bypassing `dyre` by exposing `taffybarMain` (Christian Hoener zu Siederdissen)
35
- * Textual CPU and memory monitors (Zakhar Voit)
36
- * A new window switcher menu in the pager (José Alfredo Romero L)
37
- * Dynamic workspace support in the workspace switcher (Nick Hu)
38
- * More configurable network monitor (Arseniy Seroka)
39
- * New widget: text-based command runner (Arseniy Seroka)
40
- * The Graph widget supports lines graphs (via graphDataStyles) (Joachim Breitner)
41
- * Compile with gtk2hs 0.13
42
-
43
-## Bug Fixes
44
-
45
- * Reduce wakeups by tweaking the default GHC RTS options (Joachim Breitner)
46
- * UTF8 fixes (Nathan Maxson)
47
- * Various fixes to EWMH support (José Alfredo Romero L)
48
-
49
-## Deprecations
50
-
51
-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.
52
-
53
-
54
-# 0.3.0:
55
-
56
- * 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.
57
- * Added an MPRIS2 widget (contributed by Igor Babuschkin)
58
- * Ported to use the newer merged dbus library instead of dbus-client/dbus-core (contributed by CJ van den Berg)
59
- * Finally have the calendar widget pop up over the date/time widget (contributed by José A. Romero)
60
- * GHC 7.6 compatibility
61
- * Vertical bars can now have dynamic background colors (suggested by Elliot Wolk)
62
- * Bug fixes
63
-
64
-# 0.2.1:
65
-
66
- * More robust strut handling for multiple monitors of different sizes (contributed by Morgan Gibson)
67
- * New widgets from José A. Romero (network monitor, fs monitor, another CPU monitor)
68
- * Allow the bar widget to grow vertically (also contributed by José A. Romero)
69
-
70
-# 0.2.0:
71
-
72
- * Add some more flexible formatting options for the XMonadLog widget (contributed by cnervi).
73
- * Make the PollingLabel more robust with an exception handler for IOExceptions
74
- * Added more documentation for a few widgets
75
-
76
-# 0.1.3:
77
-
78
- * Depend on gtk 0.12.1+ to be able to build under ghc 7.2
79
- * Fix the background colors in the calendar so that it follows the GTK theme instead of the bar-specific color settings
80
- * Fix the display of non-ASCII window titles in the XMonad log applet (assuming you use the dbusLog function)
81
- * Add a horrible hack to force the bar to not resize to be larger than the screen due to notifications or long window titles
82
-
83
-# 0.1.2:
84
-
85
- * Readable widget for freedesktop notifications
86
- * Fixed a few potential deadlocks on startup
87
- * 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 @@
1
-Copyright (c)2011, Tristan Ravitch
2
-
3
-All rights reserved.
4
-
5
-Redistribution and use in source and binary forms, with or without
6
-modification, are permitted provided that the following conditions are met:
7
-
8
-    * Redistributions of source code must retain the above copyright
9
-      notice, this list of conditions and the following disclaimer.
10
-
11
-    * Redistributions in binary form must reproduce the above
12
-      copyright notice, this list of conditions and the following
13
-      disclaimer in the documentation and/or other materials provided
14
-      with the distribution.
15
-
16
-    * Neither the name of Tristan Ravitch nor the names of other
17
-      contributors may be used to endorse or promote products derived
18
-      from this software without specific prior written permission.
19
-
20
-THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
21
-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
22
-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
23
-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
24
-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
25
-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
26
-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
27
-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
28
-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
29
-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
30
-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

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

@@ -1,39 +0,0 @@
1
-This is a desktop information bar intended for use with XMonad and
2
-similar window managers.  It is similar in spirit to xmobar; it is
3
-different in that it gives up some simplicity for a reasonable helping
4
-of eye candy.  This bar is based on GTK+ (via gtk2hs) and uses fancy
5
-graphics where doing so is reasonable and useful.  Example:
6
-
7
-![](https://github.com/travitch/taffybar/blob/master/doc/screenshot.png)
8
-
9
-The bar is configured much like XMonad.  It uses
10
-~/.config/taffybar/taffybar.hs as its configuration file.  This file
11
-is just a Haskell program that invokes the real _main_ function with a
12
-configuration object.  The configuration file basically just specifies
13
-which widgets to use, though any arbitrary Haskell code can be
14
-executed before the bar is created.
15
-
16
-There are some generic pre-defined widgets available:
17
-
18
- * Graph (modeled after the graph widget in Awesome)
19
- * Vertical bar (also similar to a widget in Awesome)
20
- * Periodically-updating labels, graphs, and vertical bars
21
-
22
-There are also several more specialized widgets:
23
-
24
- * Battery widget
25
- * Textual clock
26
- * Freedesktop.org notifications (via dbus)
27
- * MPRIS1 and MPRIS2 widgets
28
- * Weather widget
29
- * XMonad log widget (listens on dbus instead of stdin)
30
- * System tray
31
-
32
-TODO
33
-====
34
-
35
-An incomplete list of things that would be cool to have:
36
-
37
- * xrandr widget (for dealing changing clone/extend mode and orientation)
38
- * Better behavior when adding/removing monitors (never tried it)
39
- * Make MPRIS more configurable

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

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

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


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

@@ -1,9 +0,0 @@
1
-module Main ( main ) where
2
-
3
-import System.Taffybar
4
-
5
-main :: IO ()
6
-main = do
7
-  defaultTaffybar defaultTaffybarConfig

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

@@ -1,187 +0,0 @@
1
-{-# LANGUAGE OverloadedStrings #-}
2
-module System.Information.Battery (
3
-  -- * Types
4
-  BatteryContext,
5
-  BatteryInfo(..),
6
-  BatteryState(..),
7
-  BatteryTechnology(..),
8
-  BatteryType(..),
9
-  -- * Accessors
10
-  batteryContextNew,
11
-  getBatteryInfo
12
-  ) where
13
-
14
-import Data.Map ( Map )
15
-import qualified Data.Map as M
16
-import Data.Maybe ( fromMaybe )
17
-import Data.Word
18
-import Data.Int
19
-import DBus
20
-import DBus.Client
21
-import Data.List ( find, isInfixOf )
22
-import Data.Text ( Text )
23
-import qualified Data.Text as T
24
-import Safe ( atMay )
25
-
26
-data BatteryContext = BC Client ObjectPath
27
-
28
-data BatteryType = BatteryTypeUnknown
29
-                 | BatteryTypeLinePower
30
-                 | BatteryTypeBatteryType
31
-                 | BatteryTypeUps
32
-                 | BatteryTypeMonitor
33
-                 | BatteryTypeMouse
34
-                 | BatteryTypeKeyboard
35
-                 | BatteryTypePda
36
-                 | BatteryTypePhone
37
-                 deriving (Show, Ord, Eq, Enum)
38
-
39
-data BatteryState = BatteryStateUnknown
40
-                  | BatteryStateCharging
41
-                  | BatteryStateDischarging
42
-                  | BatteryStateEmpty
43
-                  | BatteryStateFullyCharged
44
-                  | BatteryStatePendingCharge
45
-                  | BatteryStatePendingDischarge
46
-                  deriving (Show, Ord, Eq, Enum)
47
-
48
-data BatteryTechnology = BatteryTechnologyUnknown
49
-                       | BatteryTechnologyLithiumIon
50
-                       | BatteryTechnologyLithiumPolymer
51
-                       | BatteryTechnologyLithiumIronPhosphate
52
-                       | BatteryTechnologyLeadAcid
53
-                       | BatteryTechnologyNickelCadmium
54
-                       | BatteryTechnologyNickelMetalHydride
55
-                       deriving (Show, Ord, Eq, Enum)
56
-
57
-data BatteryInfo = BatteryInfo { batteryNativePath :: Text
58
-                               , batteryVendor :: Text
59
-                               , batteryModel :: Text
60
-                               , batterySerial :: Text
61
-                               -- , batteryUpdateTime :: Time
62
-                               , batteryType :: BatteryType
63
-                               , batteryPowerSupply :: Bool
64
-                               , batteryHasHistory :: Bool
65
-                               , batteryHasStatistics :: Bool
66
-                               , batteryOnline :: Bool
67
-                               , batteryEnergy :: Double
68
-                               , batteryEnergyEmpty :: Double
69
-                               , batteryEnergyFull :: Double
70
-                               , batteryEnergyFullDesign :: Double
71
-                               , batteryEnergyRate :: Double
72
-                               , batteryVoltage :: Double
73
-                               , batteryTimeToEmpty :: Int64
74
-                               , batteryTimeToFull :: Int64
75
-                               , batteryPercentage :: Double
76
-                               , batteryIsPresent :: Bool
77
-                               , batteryState :: BatteryState
78
-                               , batteryIsRechargable :: Bool
79
-                               , batteryCapacity :: Double
80
-                               , batteryTechnology :: BatteryTechnology
81
-{-                               , batteryRecallNotice :: Bool
82
-                               , batteryRecallVendor :: Text
83
-                               , batteryRecallUr :: Text
84
--}
85
-                               }
86
-
87
-firstBattery :: [ObjectPath] -> Maybe ObjectPath
88
-firstBattery = find (isInfixOf "BAT" . formatObjectPath)
89
-
90
-powerBusName :: BusName
91
-powerBusName = "org.freedesktop.UPower"
92
-
93
-powerBaseObjectPath :: ObjectPath
94
-powerBaseObjectPath = "/org/freedesktop/UPower"
95
-
96
-readDict :: (IsVariant a) => Map Text Variant -> Text -> a -> a
97
-readDict dict key dflt = fromMaybe dflt $ do
98
-  variant <- M.lookup key dict
99
-  fromVariant variant
100
-
101
-readDictIntegral :: Map Text Variant -> Text -> Int32 -> Int
102
-readDictIntegral dict key dflt = fromMaybe (fromIntegral dflt) $ do
103
-  v <- M.lookup key dict
104
-  case variantType v of
105
-    TypeWord8   -> return $ fromIntegral (f v :: Word8)
106
-    TypeWord16  -> return $ fromIntegral (f v :: Word16)
107
-    TypeWord32  -> return $ fromIntegral (f v :: Word32)
108
-    TypeWord64  -> return $ fromIntegral (f v :: Word64)
109
-    TypeInt16   -> return $ fromIntegral (f v :: Int16)
110
-    TypeInt32   -> return $ fromIntegral (f v :: Int32)
111
-    TypeInt64   -> return $ fromIntegral (f v :: Int64)
112
-    _           -> Nothing
113
-  where
114
-    f :: (Num a, IsVariant a) => Variant -> a
115
-    f = fromMaybe (fromIntegral dflt) . fromVariant
116
-
117
-getBatteryInfo :: BatteryContext -> IO (Maybe BatteryInfo)
118
-getBatteryInfo (BC systemConn battPath) = do
119
-  -- Grab all of the properties of the battery each call with one
120
-  -- message.
121
-  reply <- call_ systemConn (methodCall battPath "org.freedesktop.DBus.Properties" "GetAll")
122
-                             { methodCallDestination = Just "org.freedesktop.UPower"
123
-                             , methodCallBody = [toVariant $ T.pack "org.freedesktop.UPower.Device"]
124
-                             }
125
-
126
-  return $ do
127
-    body <- methodReturnBody reply `atMay` 0
128
-    dict <- fromVariant body
129
-    return BatteryInfo { batteryNativePath = readDict dict "NativePath" ""
130
-                       , batteryVendor = readDict dict "Vendor" ""
131
-                       , batteryModel = readDict dict "Model" ""
132
-                       , batterySerial = readDict dict "Serial" ""
133
-                       , batteryType = toEnum $ fromIntegral $ readDictIntegral dict "Type" 0
134
-                       , batteryPowerSupply = readDict dict "PowerSupply" False
135
-                       , batteryHasHistory = readDict dict "HasHistory" False
136
-                       , batteryHasStatistics = readDict dict "HasStatistics" False
137
-                       , batteryOnline = readDict dict "Online" False
138
-                       , batteryEnergy = readDict dict "Energy" 0.0
139
-                       , batteryEnergyEmpty = readDict dict "EnergyEmpty" 0.0
140
-                       , batteryEnergyFull = readDict dict "EnergyFull" 0.0
141
-                       , batteryEnergyFullDesign = readDict dict "EnergyFullDesign" 0.0
142
-                       , batteryEnergyRate = readDict dict "EnergyRate" 0.0
143
-                       , batteryVoltage = readDict dict "Voltage" 0.0
144
-                       , batteryTimeToEmpty = readDict dict "TimeToEmpty" 0
145
-                       , batteryTimeToFull = readDict dict "TimeToFull" 0
146
-                       , batteryPercentage = readDict dict "Percentage" 0.0
147
-                       , batteryIsPresent = readDict dict "IsPresent" False
148
-                       , batteryState = toEnum $ readDictIntegral dict "State" 0
149
-                       , batteryIsRechargable = readDict dict "IsRechargable" True
150
-                       , batteryCapacity = readDict dict "Capacity" 0.0
151
-                       , batteryTechnology =
152
-                         toEnum $ fromIntegral $ readDictIntegral dict "Technology" 0
153
-                       }
154
-
155
-batteryContextNew :: IO (Maybe BatteryContext)
156
-batteryContextNew = do
157
-  systemConn <- connectSystem
158
-
159
-  -- First, get the list of devices.  For now, we just get the stats
160
-  -- for the first battery
161
-  reply <- call_ systemConn (methodCall powerBaseObjectPath "org.freedesktop.UPower" "EnumerateDevices")
162
-        { methodCallDestination = Just powerBusName
163
-        }
164
-  return $ do
165
-    body <- methodReturnBody reply `atMay` 0
166
-    powerDevices <- fromVariant body
167
-    battPath <- firstBattery powerDevices
168
-    return $ BC systemConn battPath

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

@@ -1,35 +0,0 @@
1
-module System.Information.CPU ( cpuLoad ) where
2
-
3
-import Control.Concurrent ( threadDelay )
4
-import System.IO ( IOMode(ReadMode), openFile, hGetLine, hClose )
5
-
6
-procData :: IO [Double]
7
-procData = do
8
-  h <- openFile "/proc/stat" ReadMode
9
-  firstLine <- hGetLine h
10
-  (length firstLine) `seq` return ()
11
-  hClose h
12
-  return (procParser firstLine)
13
-
14
-procParser :: String -> [Double]
15
-procParser = map read . tail . words
16
-
17
-truncVal :: Double -> Double
18
-truncVal v
19
-  | isNaN v || v < 0.0 = 0.0
20
-  | otherwise = v
21
-
22
-cpuLoad :: IO (Double, Double, Double)
23
-cpuLoad = do
24
-  a <- procData
25
-  threadDelay 50000
26
-  b <- procData
27
-  let dif = zipWith (-) b a
28
-      tot = foldr (+) 0 dif
29
-      pct = map (/ tot) dif
30
-      user = foldr (+) 0 $ take 2 pct
31
-      system = pct !! 2
32
-      t = user + system
33
-  return (truncVal user, truncVal system, truncVal t)

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

@@ -1,57 +0,0 @@
1
------------------------------------------------------------------------------
2
---
3
---
4
---
5
------------------------------------------------------------------------------
6
-
7
-module System.Information.CPU2 ( getCPULoad, getCPUInfo, getCPUTemp ) where
8
-
9
-import Data.Maybe ( mapMaybe )
10
-import Safe ( atMay, readDef, tailSafe )
11
-import System.Information.StreamInfo ( getLoad, getParsedInfo )
12
-import Control.Monad (liftM)
13
-
14
-getCPULoad :: String -> IO [Double]
15
-getCPULoad cpu = do
16
-  load <- getLoad 0.05 $ getCPUInfo cpu
17
-  case load of
18
-    l0:l1:l2:_ -> return [ l0 + l1, l2 ]
19
-    _ -> return []
20
-
21
-getCPUTemp :: [String] -> IO [Int]
22
-getCPUTemp cpus = do
23
-    let cpus' = map (\s -> [last s]) cpus
24
-    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'
25
-    --TODO and suppoprt for more than 1 physical cpu.
26
-
27
-getCPUInfo :: String -> IO [Int]
28
-getCPUInfo = getParsedInfo "/proc/stat" parse
29
-
30
-parse :: String -> [(String, [Int])]
31
-parse = mapMaybe (tuplize . words) . filter (\x -> take 3 x == "cpu") . lines
32
-
33
-tuplize :: [String] -> Maybe (String, [Int])
34
-tuplize s = do
35
-  cpu <- s `atMay` 0
36
-  return (cpu, map (readDef (-1)) (tailSafe s))
37
-

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

@@ -1,42 +0,0 @@
1
------------------------------------------------------------------------------
2
---
3
---
4
------------------------------------------------------------------------------
5
-
6
-module System.Information.DiskIO ( getDiskTransfer ) where
7
-
8
-import Data.Maybe ( mapMaybe )
9
-import Safe ( atMay, headMay, readDef )
10
-import System.Information.StreamInfo ( getParsedInfo, getTransfer )
11
-
12
-getDiskTransfer :: String -> IO [Double]
13
-getDiskTransfer disk = getTransfer 0.05 $ getDiskInfo disk
14
-
15
-getDiskInfo :: String -> IO [Int]
16
-getDiskInfo = getParsedInfo "/proc/diskstats" parse
17
-
18
-parse :: String -> [(String, [Int])]
19
-parse = mapMaybe tuplize . map (drop 2 . words) . lines
20
-
21
-tuplize :: [String] -> Maybe (String, [Int])
22
-tuplize s = do
23
-  device <- headMay s
24
-  used <- s `atMay` 3
25
-  capacity <- s `atMay` 7
26
-  return (device, [readDef (-1) used, readDef (-1) capacity])
27
-

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

@@ -1,149 +0,0 @@
1
------------------------------------------------------------------------------
2
---
3
---
4
---
5
---
6
------------------------------------------------------------------------------
7
-
8
-module System.Information.EWMHDesktopInfo
9
-  ( X11Window      -- re-exported from X11DesktopInfo
10
-  , X11WindowHandle
11
-  , WorkspaceIdx(..)
12
-  , withDefaultCtx -- re-exported from X11DesktopInfo
13
-  , isWindowUrgent -- re-exported from X11DesktopInfo
14
-  , getCurrentWorkspace
15
-  , getVisibleWorkspaces
16
-  , getWorkspaceNames
17
-  , switchToWorkspace
18
-  , switchOneWorkspace
19
-  , getWindowTitle
20
-  , getWindowClass
21
-  , getActiveWindowTitle
22
-  , getWindows
23
-  , getWindowHandles
24
-  , getWorkspace
25
-  , focusWindow
26
-  ) where
27
-
28
-import Control.Applicative ((<$>))
29
-import Data.Tuple (swap)
30
-import Data.Maybe (listToMaybe, mapMaybe)
31
-import System.Information.X11DesktopInfo
32
-
33
-type X11WindowHandle = ((WorkspaceIdx, String, String), X11Window)
34
-
35
-newtype WorkspaceIdx = WSIdx Int
36
-                     deriving (Show, Read, Ord, Eq)
37
-
38
-noFocus :: String
39
-noFocus = "..."
40
-
41
-getCurrentWorkspace :: X11Property WorkspaceIdx
42
-getCurrentWorkspace = WSIdx <$> readAsInt Nothing "_NET_CURRENT_DESKTOP"
43
-
44
-getVisibleWorkspaces :: X11Property [WorkspaceIdx]
45
-getVisibleWorkspaces = do
46
-  vis <- getVisibleTags
47
-  allNames <- map swap <$> getWorkspaceNames
48
-  cur <- getCurrentWorkspace
49
-  return $ cur : mapMaybe (flip lookup allNames) vis
50
-
51
-getWorkspaceNames :: X11Property [(WorkspaceIdx, String)]
52
-getWorkspaceNames = go <$> readAsListOfString Nothing "_NET_DESKTOP_NAMES"
53
-  where go = zip [WSIdx i | i <- [0..]]
54
-
55
-switchToWorkspace :: WorkspaceIdx -> X11Property ()
56
-switchToWorkspace (WSIdx idx) = do
57
-  cmd <- getAtom "_NET_CURRENT_DESKTOP"
58
-  sendCommandEvent cmd (fromIntegral idx)
59
-
60
-switchOneWorkspace :: Bool -> Int -> X11Property ()
61
-switchOneWorkspace dir end = do
62
-  cur <- getCurrentWorkspace
63
-  switchToWorkspace $ if dir then getPrev cur end else getNext cur end
64
-
65
-getPrev :: WorkspaceIdx -> Int -> WorkspaceIdx
66
-getPrev (WSIdx idx) end
67
-  | idx > 0 = WSIdx $ idx-1
68
-  | otherwise = WSIdx end
69
-
70
-getNext :: WorkspaceIdx -> Int -> WorkspaceIdx
71
-getNext (WSIdx idx) end
72
-  | idx < end = WSIdx $ idx+1
73
-  | otherwise = WSIdx 0
74
-
75
-getWindowTitle :: X11Window -> X11Property String
76
-getWindowTitle window = do
77
-  let w = Just window
78
-  prop <- readAsString w "_NET_WM_NAME"
79
-  case prop of
80
-    "" -> readAsString w "WM_NAME"
81
-    _  -> return prop
82
-
83
-getWindowClass :: X11Window -> X11Property String
84
-getWindowClass window = readAsString (Just window) "WM_CLASS"
85
-
86
-withActiveWindow :: (X11Window -> X11Property String) -> X11Property String
87
-withActiveWindow getProp = do
88
-  awt <- readAsListOfWindow Nothing "_NET_ACTIVE_WINDOW"
89
-  let w = listToMaybe $ filter (>0) awt
90
-  maybe (return noFocus) getProp w
91
-
92
-getActiveWindowTitle :: X11Property String
93
-getActiveWindowTitle = withActiveWindow getWindowTitle
94
-
95
-getWindows :: X11Property [X11Window]
96
-getWindows = readAsListOfWindow Nothing "_NET_CLIENT_LIST"
97
-
98
-getWindowHandles :: X11Property [X11WindowHandle]
99
-getWindowHandles = do
100
-  windows <- getWindows
101
-  workspaces <- mapM getWorkspace windows
102
-  wtitles <- mapM getWindowTitle windows
103
-  wclasses <- mapM getWindowClass windows
104
-  return $ zip (zip3 workspaces wtitles wclasses) windows
105
-
106
-getWorkspace :: X11Window -> X11Property WorkspaceIdx
107
-getWorkspace window = WSIdx <$> readAsInt (Just window) "_NET_WM_DESKTOP"
108
-
109
-focusWindow :: X11Window -> X11Property ()
110
-focusWindow wh = do
111
-  cmd <- getAtom "_NET_ACTIVE_WINDOW"
112
-  sendWindowEvent cmd (fromIntegral wh)

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

@@ -1,43 +0,0 @@
1
-module System.Information.Memory (
2
-  MemoryInfo(..),
3
-  parseMeminfo
4
-  ) where
5
-
6
-toMB :: String -> Double
7
-toMB size = (read size :: Double) / 1024
8
-
9
-data MemoryInfo = MemoryInfo { memoryTotal :: Double
10
-                             , memoryFree :: Double
11
-                             , memoryBuffer :: Double
12
-                             , memoryCache :: Double
13
-                             , memoryRest :: Double      -- free + buffer + cache
14
-                             , memoryUsed :: Double      -- total - rest
15
-                             , memoryUsedRatio :: Double -- used / total
16
-                             }
17
-
18
-emptyMemoryInfo :: MemoryInfo
19
-emptyMemoryInfo = MemoryInfo 0 0 0 0 0 0 0
20
-
21
-parseLines :: [String] -> MemoryInfo -> MemoryInfo
22
-parseLines (line:rest) memInfo = parseLines rest newMemInfo
23
-  where (label:size:_) = words line
24
-        newMemInfo = case label of
25
-                       "MemTotal:" -> memInfo { memoryTotal = toMB size }
26
-                       "MemFree:"  -> memInfo { memoryFree = toMB size }
27
-                       "Buffers:"  -> memInfo { memoryBuffer = toMB size }
28
-                       "Cached:"   -> memInfo { memoryCache = toMB size }
29
-                       _           -> memInfo
30
-parseLines _ memInfo = memInfo
31
-
32
-parseMeminfo :: IO MemoryInfo
33
-parseMeminfo = do
34
-  s <- readFile "/proc/meminfo"
35
-  let m = parseLines (lines s) emptyMemoryInfo
36
-      rest = memoryFree m + memoryBuffer m + memoryCache m
37
-      used = memoryTotal m - rest
38
-      usedRatio = used / memoryTotal m
39
-  return m { memoryRest = rest
40
-           , memoryUsed = used
41
-           , memoryUsedRatio = usedRatio
42
-           }
43
-

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

@@ -1,53 +0,0 @@
1
------------------------------------------------------------------------------
2
---
3
---
4
---
5
------------------------------------------------------------------------------
6
-
7
-module System.Information.Network ( getNetInfo ) where
8
-
9
-import Control.Applicative
10
-import Data.Maybe ( mapMaybe )
11
-import Safe ( atMay, initSafe, readDef )
12
-import System.Information.StreamInfo ( getParsedInfo )
13
-
14
-import Prelude
15
-
16
-getNetInfo :: String -> IO (Maybe [Integer])
17
-getNetInfo iface = do
18
-  isUp <- isInterfaceUp iface
19
-  case isUp of
20
-    True -> Just <$> getParsedInfo "/proc/net/dev" parse iface
21
-    False -> return Nothing
22
-
23
-parse :: String -> [(String, [Integer])]
24
-parse = mapMaybe tuplize . map words . drop 2 . lines
25
-
26
-tuplize :: [String] -> Maybe (String, [Integer])
27
-tuplize s = do
28
-  dev <- initSafe <$> s `atMay` 0
29
-  down <- readDef (-1) <$> s `atMay` 1
30
-  up <- readDef (-1) <$> s `atMay` out
31
-  return (dev, [down, up])
32
-  where
33
-    out = (length s) - 8
34
-
35
-isInterfaceUp :: String -> IO Bool
36
-isInterfaceUp iface = do
37
-  state <- readFile $ "/sys/class/net/" ++ iface ++ "/operstate"
38
-  case state of
39
-    'u' : _ -> return True
40
-    _ -> return False

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

@@ -1,90 +0,0 @@
1
---------------------------------------------------------------------------------
2
---
3
---
4
---
5
---------------------------------------------------------------------------------
6
-
7
-module System.Information.StreamInfo
8
-    ( getParsedInfo
9
-    , getLoad
10
-    , getAccLoad
11
-    , getTransfer
12
-    ) where
13
-
14
-import Control.Concurrent ( threadDelay )
15
-import Data.IORef
16
-import Data.Maybe ( fromMaybe )
17
-
18
-getParsedInfo :: FilePath -> (String -> [(String, [a])]) -> String -> IO [a]
19
-getParsedInfo path parser selector = do
20
-    file <- readFile path
21
-    (length file) `seq` return ()
22
-    return (fromMaybe [] $ lookup selector $ parser file)
23
-
24
-truncVal :: (RealFloat a) => a -> a
25
-truncVal v
26
-  | isNaN v || v < 0.0 = 0.0
27
-  | otherwise = v
28
-
29
-toRatioList :: (Integral a, RealFloat b) => [a] -> [b]
30
-toRatioList deltas = map truncVal ratios
31
-    where total = fromIntegral $ foldr (+) 0 deltas
32
-          ratios = map ((/total) . fromIntegral) deltas
33
-
34
-probe :: (Num a, RealFrac b) => IO [a] -> b -> IO [a]
35
-probe action delay = do
36
-    a <- action
37
-    threadDelay $ round (delay * 1e6)
38
-    b <- action
39
-    return $ zipWith (-) b a
40
-
41
-accProbe :: (Num a) => IO [a] -> IORef [a] -> IO [a]
42
-accProbe action sample = do
43
-    a <- readIORef sample
44
-    b <- action
45
-    writeIORef sample b
46
-    return $ zipWith (-) b a
47
-
48
-getTransfer :: (Integral a, RealFloat b) => b -> IO [a] -> IO [b]
49
-getTransfer interval action = do
50
-    deltas <- probe action interval
51
-    return $ map (truncVal . (/interval) . fromIntegral) deltas
52
-
53
-getLoad :: (Integral a, RealFloat b) => b -> IO [a] -> IO [b]
54
-getLoad interval action = do
55
-    deltas <- probe action interval
56
-    return $ toRatioList deltas
57
-
58
-getAccLoad :: (Integral a, RealFloat b) => IORef [a] -> IO [a] -> IO [b]
59
-getAccLoad sample action = do
60
-     deltas <- accProbe action sample
61
-     return $ toRatioList deltas
62
-

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

@@ -1,205 +0,0 @@
1
------------------------------------------------------------------------------
2
---
3
---
4
---
5
---
6
------------------------------------------------------------------------------
7
-
8
-module System.Information.X11DesktopInfo
9
-  ( X11Context
10
-  , X11Property
11
-  , X11Window
12
-  , withDefaultCtx
13
-  , readAsInt
14
-  , readAsString
15
-  , readAsListOfString
16
-  , readAsListOfWindow
17
-  , isWindowUrgent
18
-  , getVisibleTags
19
-  , getAtom
20
-  , eventLoop
21
-  , sendCommandEvent
22
-  , sendWindowEvent
23
-  ) where
24
-
25
-import Codec.Binary.UTF8.String as UTF8
26
-import Control.Monad.Reader
27
-import Data.Bits (testBit, (.|.))
28
-import Data.List.Split (endBy)
29
-import Data.Maybe (fromMaybe)
30
-import Graphics.X11.Xlib
31
-import Graphics.X11.Xlib.Extras
32
-
33
-data X11Context = X11Context { contextDisplay :: Display, contextRoot :: Window }
34
-type X11Property a = ReaderT X11Context IO a
35
-type X11Window = Window
36
-type PropertyFetcher a = Display -> Atom -> Window -> IO (Maybe [a])
37
-
38
-withDefaultCtx :: X11Property a -> IO a
39
-withDefaultCtx fun = do
40
-  ctx <- getDefaultCtx
41
-  res <- runReaderT fun ctx
42
-  closeDisplay (contextDisplay ctx)
43
-  return res
44
-
45
-readAsInt :: Maybe X11Window -- ^ window to read from. Nothing means the root window.
46
-          -> String -- ^ name of the property to retrieve
47
-          -> X11Property Int
48
-readAsInt window name = do
49
-  prop <- fetch getWindowProperty32 window name
50
-  case prop of
51
-    Just (x:_) -> return (fromIntegral x)
52
-    _          -> return (-1)
53
-
54
-readAsString :: Maybe X11Window -- ^ window to read from. Nothing means the root window.
55
-             -> String          -- ^ name of the property to retrieve
56
-             -> X11Property String
57
-readAsString window name = do
58
-  prop <- fetch getWindowProperty8 window name
59
-  case prop of
60
-    Just xs -> return . UTF8.decode . map fromIntegral $ xs
61
-    _       -> return []
62
-
63
-readAsListOfString :: Maybe X11Window -- ^ window to read from. Nothing means the root window.
64
-                   -> String          -- ^ name of the property to retrieve
65
-                   -> X11Property [String]
66
-readAsListOfString window name = do
67
-  prop <- fetch getWindowProperty8 window name
68
-  case prop of
69
-    Just xs -> return (parse xs)
70
-    _       -> return []
71
-  where
72
-    parse = endBy "\0" . UTF8.decode . map fromIntegral
73
-
74
-readAsListOfWindow :: Maybe X11Window -- ^ window to read from. Nothing means the root window.
75
-                   -> String          -- ^ name of the property to retrieve
76
-                   -> X11Property [X11Window]
77
-readAsListOfWindow window name = do
78
-  prop <- fetch getWindowProperty32 window name
79
-  case prop of
80
-    Just xs -> return $ map fromIntegral xs
81
-    _       -> return []
82
-
83
-isWindowUrgent :: X11Window -> X11Property Bool
84
-isWindowUrgent window = do
85
-  hints <- fetchWindowHints window
86
-  return $ testBit (wmh_flags hints) urgencyHintBit
87
-
88
-getVisibleTags :: X11Property [String]
89
-getVisibleTags = return =<<
90
-  readAsListOfString Nothing "_XMONAD_VISIBLE_WORKSPACES"
91
-
92
-getAtom :: String -> X11Property Atom
93
-getAtom s = do
94
-  (X11Context d _) <- ask
95
-  atom <- liftIO $ internAtom d s False
96
-  return atom
97
-
98
-eventLoop :: (Event -> IO ()) -> X11Property ()
99
-eventLoop dispatch = do
100
-  (X11Context d w) <- ask
101
-  liftIO $ do
102
-    xSetErrorHandler
103
-    selectInput d w $ propertyChangeMask .|. substructureNotifyMask
104
-    allocaXEvent $ \e -> forever $ do
105
-      event <- nextEvent d e >> getEvent e
106
-      case event of
107
-        MapNotifyEvent _ _ _ _ _ window _ -> do
108
-          selectInput d window propertyChangeMask
109
-        _ -> return ()
110
-      dispatch event
111
-
112
-sendCommandEvent :: Atom -> Atom -> X11Property ()
113
-sendCommandEvent cmd arg = do
114
-  (X11Context dpy root) <- ask
115
-  sendCustomEvent dpy cmd arg root root
116
-
117
-sendWindowEvent :: Atom -> X11Window -> X11Property ()
118
-sendWindowEvent cmd win = do
119
-  (X11Context dpy root) <- ask
120
-  sendCustomEvent dpy cmd cmd root win
121
-
122
-getDefaultCtx :: IO X11Context
123
-getDefaultCtx = do
124
-  d <- openDisplay ""
125
-  w <- rootWindow d $ defaultScreen d
126
-  return $ X11Context d w
127
-
128
-fetch :: (Integral a)
129
-      => PropertyFetcher a -- ^ Function to use to retrieve the property.
130
-      -> Maybe X11Window   -- ^ Window to read from. Nothing means the root Window.
131
-      -> String            -- ^ Name of the property to retrieve.
132
-      -> X11Property (Maybe [a])
133
-fetch fetcher window name = do
134
-  (X11Context dpy root) <- ask
135
-  atom <- getAtom name
136
-  prop <- liftIO $ fetcher dpy atom (fromMaybe root window)
137
-  return prop
138
-
139
-fetchWindowHints :: X11Window -> X11Property WMHints
140
-fetchWindowHints window = do
141
-  (X11Context d _) <- ask
142
-  hints <- liftIO $ getWMHints d window
143
-  return hints
144
-
145
-sendCustomEvent :: Display
146
-                -> Atom
147
-                -> Atom
148
-                -> X11Window
149
-                -> X11Window
150
-                -> X11Property ()
151
-sendCustomEvent dpy cmd arg root win = do
152
-  liftIO $ allocaXEvent $ \e -> do
153
-    setEventType e clientMessage
154
-    setClientMessageEvent e win cmd 32 arg currentTime
155
-    sendEvent dpy root False structureNotifyMask e
156
-    sync dpy False

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

@@ -1,305 +0,0 @@
1
-module System.Taffybar (
2
-  -- * Detail
3
-  --
4
-  -- | This is a system status bar meant for use with window manager
5
-  -- like XMonad.  It is similar to xmobar, but with more visual flare
6
-  -- and a different widget set.  Contributed widgets are more than
7
-  -- welcome.  The bar is drawn using gtk and cairo.  It is actually
8
-  -- the simplest possible thing that could plausibly work: you give
9
-  -- Taffybar a list of GTK widgets and it will render them in a
10
-  -- horizontal bar for you (taking care of ugly details like
11
-  -- reserving strut space so that window managers don't put windows
12
-  -- over it).
13
-  --
14
-  -- This is the real main module.  The default bar should be
15
-  -- customized to taste in the config file
16
-  -- (~/.config/taffybar/taffybar.hs).  Typically, this means adding
17
-  -- widgets to the default config.  A default configuration file is
18
-  -- included in the distribution, but the essentials are covered
19
-  -- here.
20
-
21
-  -- * Config File
22
-  --
23
-  -- | The config file is just a Haskell source file that is compiled
24
-  -- at startup (if it has changed) to produce a custom executable
25
-  -- with the desired set of widgets.  You will want to import this
26
-  -- module along with the modules of any widgets you want to add to
27
-  -- the bar.  Note, you can define any widgets that you want in your
28
-  -- config file or other libraries.  Taffybar only cares that you
29
-  -- give it some GTK widgets to display.
30
-  --
31
-  -- Below is a fairly typical example:
32
-  --
33
-  -- > import System.Taffybar
34
-  -- > import System.Taffybar.Systray
35
-  -- > import System.Taffybar.XMonadLog
36
-  -- > import System.Taffybar.SimpleClock
37
-  -- > import System.Taffybar.Widgets.PollingGraph
38
-  -- > import System.Information.CPU
39
-  -- >
40
-  -- > cpuCallback = do
41
-  -- >   (_, systemLoad, totalLoad) <- cpuLoad
42
-  -- >   return [ totalLoad, systemLoad ]
43
-  -- >
44
-  -- > main = do
45
-  -- >   let cpuCfg = defaultGraphConfig { graphDataColors = [ (0, 1, 0, 1), (1, 0, 1, 0.5)]
46
-  -- >                                   , graphLabel = Just "cpu"
47
-  -- >                                   }
48
-  -- >       clock = textClockNew Nothing "<span fgcolor='orange'>%a %b %_d %H:%M</span>" 1
49
-  -- >       log = xmonadLogNew
50
-  -- >       tray = systrayNew
51
-  -- >       cpu = pollingGraphNew cpuCfg 0.5 cpuCallback
52
-  -- >   defaultTaffybar defaultTaffybarConfig { startWidgets = [ log ]
53
-  -- >                                         , endWidgets = [ tray, clock, cpu ]
54
-  -- >                                         }
55
-  --
56
-  -- This configuration creates a bar with four widgets.  On the left is
57
-  -- the XMonad log.  The rightmost widget is the system tray, with a
58
-  -- clock and then a CPU graph.  The clock is formatted using standard
59
-  -- strftime-style format strings (see the clock module).  Note that
60
-  -- the clock is colored using Pango markup (again, see the clock
61
-  -- module).
62
-  --
63
-  -- The CPU widget plots two graphs on the same widget: total CPU use
64
-  -- in green and then system CPU use in a kind of semi-transparent
65
-  -- purple on top of the green.
66
-  --
67
-  -- It is important to note that the widget lists are *not* [Widget].
68
-  -- They are actually [IO Widget] since the bar needs to construct them
69
-  -- after performing some GTK initialization.
70
-
71
-  -- * XMonad Integration (via DBus)
72
-  --
73
-  -- | The XMonadLog widget differs from its counterpart in xmobar: it
74
-  -- listens for updates over DBus instead of reading from stdin.
75
-  -- This makes it easy to restart Taffybar independently of XMonad.
76
-  -- XMonad does not come with a DBus logger, so here is an example of
77
-  -- how to make it work.  Note: this requires the dbus-core (>0.9)
78
-  -- package, which is installed as a dependency of Taffybar.
79
-  --
80
-  -- > import XMonad.Hooks.DynamicLog
81
-  -- > import XMonad.Hooks.ManageDocks
82
-  -- > import DBus.Client
83
-  -- > import System.Taffybar.XMonadLog ( dbusLog )
84
-  -- >
85
-  -- > main = do
86
-  -- >   client <- connectSession
87
-  -- >   let pp = defaultPP
88
-  -- >   xmonad defaultConfig { logHook = dbusLog client pp
89
-  -- >                        , manageHook = manageDocks
90
-  -- >                        }
91
-  --
92
-  -- The complexity is handled in the System.Tafftbar.XMonadLog
93
-  -- module.  Note that manageDocks is required to have XMonad put
94
-  -- taffybar in the strut space that it reserves.  If you have
95
-  -- problems with taffybar appearing almost fullscreen, check to
96
-  -- see if you have manageDocks in your manageHook.
97
-
98
-  -- ** A note about DBus:
99
-  -- |
100
-  -- * If you start xmonad using a graphical login manager like gdm or
101
-  --   kdm, DBus should be started automatically for you.
102
-  --
103
-  -- * If you start xmonad with a different graphical login manager that
104
-  --   does not start DBus for you automatically, put the line @eval
105
-  --   \`dbus-launch --auto-syntax\`@ into your ~\/.xsession *before*
106
-  --   xmonad and taffybar are started.  This command sets some
107
-  --   environment variables that the two must agree on.
108
-  --
109
-  -- * If you start xmonad via @startx@ or a similar command, add the
110
-  --   above command to ~\/.xinitrc
111
-
112
-  -- * Colors
113
-  --
114
-  -- | While taffybar is based on GTK+, it ignores your GTK+ theme.
115
-  -- The default theme that it uses is in
116
-  -- @~\/.cabal\/share\/taffybar-\<version\>\/taffybar.rc@.  You can
117
-  -- customize this theme by copying it to
118
-  -- @~\/.config\/taffybar\/taffybar.rc@.  For an idea of the customizations you can make,
119
-  -- see <https://live.gnome.org/GnomeArt/Tutorials/GtkThemes>.
120
-  TaffybarConfig(..),
121
-  defaultTaffybar,
122
-  defaultTaffybarConfig,
123
-  Position(..),
124
-  taffybarMain
125
-  ) where
126
-
127
-import qualified Config.Dyre as Dyre
128
-import qualified Config.Dyre.Params as Dyre
129
-import Control.Monad ( when )
130
-import Data.Maybe ( fromMaybe )
131
-import System.Environment.XDG.BaseDir ( getUserConfigFile )
132
-import System.FilePath ( (</>) )
133
-import Graphics.UI.Gtk
134
-import Safe ( atMay )
135
-import System.Exit ( exitFailure )
136
-import qualified System.IO as IO
137
-import Text.Printf ( printf )
138
-
139
-import Paths_taffybar ( getDataDir )
140
-import System.Taffybar.StrutProperties
141
-
142
-data Position = Top | Bottom
143
-  deriving (Show, Eq)
144
-
145
-
146
-strutProperties :: Position  -- ^ Bar position
147
-                -> Int       -- ^ Bar height
148
-                -> Rectangle -- ^ Current monitor rectangle
149
-                -> [Rectangle] -- ^ All monitors
150
-                -> StrutProperties
151
-strutProperties pos bh (Rectangle mX mY mW mH) monitors =
152
-    propertize pos sX sW sH
153
-    where sX = mX
154
-          sW = mW - 1
155
-          sH = case pos of Top    -> bh + mY
156
-                           Bottom -> bh + totalH - mY - mH
157
-          totalH = maximum $ map bottomY monitors
158
-          bottomY (Rectangle _ y _ h) = y + h
159
-          propertize p x w h = case p of
160
-              Top    -> (0, 0, h, 0, 0, 0, 0, 0, x, x+w, 0,   0)
161
-              Bottom -> (0, 0, 0, h, 0, 0, 0, 0, 0,   0, x, x+w)
162
-
163
-data TaffybarConfig =
164
-  TaffybarConfig { screenNumber :: Int -- ^ The screen number to run the bar on (default is almost always fine)
165
-                 , monitorNumber :: Int -- ^ The xinerama/xrandr monitor number to put the bar on (default: 0)
166
-                 , barHeight :: Int -- ^ Number of pixels to reserve for the bar (default: 25 pixels)
167
-                 , barPosition :: Position -- ^ The position of the bar on the screen (default: Top)
168
-                 , widgetSpacing :: Int -- ^ The number of pixels between widgets
169
-                 , errorMsg :: Maybe String -- ^ Used by the application
170
-                 , startWidgets :: [IO Widget] -- ^ Widgets that are packed in order at the left end of the bar
171
-                 , endWidgets :: [IO Widget] -- ^ Widgets that are packed from right-to-left in the bar
172
-                 }
173
-
174
-defaultTaffybarConfig :: TaffybarConfig
175
-defaultTaffybarConfig =
176
-  TaffybarConfig { screenNumber = 0
177
-                 , monitorNumber = 0
178
-                 , barHeight = 25
179
-                 , barPosition = Top
180
-                 , widgetSpacing = 10
181
-                 , errorMsg = Nothing
182
-                 , startWidgets = []
183
-                 , endWidgets = []
184
-                 }
185
-
186
-showError :: TaffybarConfig -> String -> TaffybarConfig
187
-showError cfg msg = cfg { errorMsg = Just msg }
188
-
189
-defaultParams :: Dyre.Params TaffybarConfig
190
-defaultParams = Dyre.defaultParams { Dyre.projectName = "taffybar"
191
-                                   , Dyre.realMain = realMain
192
-                                   , Dyre.showError = showError
193
-                                   , Dyre.ghcOpts = ["-threaded", "-rtsopts"]
194
-                                   , Dyre.rtsOptsHandling = Dyre.RTSAppend ["-I0", "-V0"]
195
-                                   }
196
-
197
-defaultTaffybar :: TaffybarConfig -> IO ()
198
-defaultTaffybar = Dyre.wrapMain defaultParams
199
-
200
-realMain :: TaffybarConfig -> IO ()
201
-realMain cfg = do
202
-  case errorMsg cfg of
203
-    Nothing -> taffybarMain cfg
204
-    Just err -> do
205
-      IO.hPutStrLn IO.stderr ("Error: " ++ err)
206
-      exitFailure
207
-
208
-getDefaultConfigFile :: String -> IO FilePath
209
-getDefaultConfigFile name = do
210
-  dataDir <- getDataDir
211
-  return (dataDir </> name)
212
-
213
-setTaffybarSize :: TaffybarConfig -> Window -> IO ()
214
-setTaffybarSize cfg window = do
215
-  screen <- windowGetScreen window
216
-  nmonitors <- screenGetNMonitors screen
217
-  allMonitorSizes <- mapM (screenGetMonitorGeometry screen) [0 .. (nmonitors - 1)]
218
-
219
-  when (monitorNumber cfg >= nmonitors) $ do
220
-    IO.hPutStrLn IO.stderr $ printf "Monitor %d is not available in the selected screen" (monitorNumber cfg)
221
-
222
-  let monitorSize = fromMaybe (allMonitorSizes !! 0) $ do
223
-        allMonitorSizes `atMay` monitorNumber cfg
224
-
225
-  let Rectangle x y w h = monitorSize
226
-      yoff = case barPosition cfg of
227
-        Top -> 0
228
-        Bottom -> h - barHeight cfg
229
-  windowMove window x (y + yoff)
230
-
231
-  -- Set up the window size using fixed min and max sizes. This
232
-  -- prevents the contained horizontal box from affecting the window
233
-  -- size.
234
-  windowSetGeometryHints window
235
-                         (Nothing :: Maybe Widget)
236
-                         (Just (w, barHeight cfg)) -- Min size.
237
-                         (Just (w, barHeight cfg)) -- Max size.
238
-                         Nothing
239
-                         Nothing
240
-                         Nothing
241
-
242
-  let setStrutProps = setStrutProperties window
243
-                      $ strutProperties (barPosition cfg)
244
-                                        (barHeight cfg)
245
-                                        monitorSize
246
-                                        allMonitorSizes
247
-
248
-  winRealized <- widgetGetRealized window
249
-  if winRealized
250
-    then setStrutProps
251
-    else onRealize window setStrutProps >> return ()
252
-
253
-taffybarMain :: TaffybarConfig -> IO ()
254
-taffybarMain cfg = do
255
-
256
-  _ <- initGUI
257
-
258
-  -- Load default and user gtk resources
259
-  defaultGtkConfig <- getDefaultConfigFile "taffybar.rc"
260
-  userGtkConfig <- getUserConfigFile "taffybar" "taffybar.rc"
261
-  rcParse defaultGtkConfig
262
-  rcParse userGtkConfig
263
-
264
-  Just disp <- displayGetDefault
265
-  nscreens <- displayGetNScreens disp
266
-  screen <- case screenNumber cfg < nscreens of
267
-    False -> error $ printf "Screen %d is not available in the default display" (screenNumber cfg)
268
-    True -> displayGetScreen disp (screenNumber cfg)
269
-
270
-  window <- windowNew
271
-  widgetSetName window "Taffybar"
272
-  windowSetTypeHint window WindowTypeHintDock
273
-  windowSetScreen window screen
274
-  setTaffybarSize cfg window
275
-
276
-  -- Reset the size of the Taffybar window if the monitor setup has
277
-  -- changed, e.g., after a laptop user has attached an external
278
-  -- monitor.
279
-  _ <- on screen screenMonitorsChanged (setTaffybarSize cfg window)
280
-
281
-  box <- hBoxNew False $ widgetSpacing cfg
282
-  containerAdd window box
283
-
284
-  mapM_ (\io -> do
285
-            wid <- io
286
-            widgetSetSizeRequest wid (-1) (barHeight cfg)
287
-            boxPackStart box wid PackNatural 0) (startWidgets cfg)
288
-  mapM_ (\io -> do
289
-            wid <- io
290
-            widgetSetSizeRequest wid (-1) (barHeight cfg)
291
-            boxPackEnd box wid PackNatural 0) (endWidgets cfg)
292
-
293
-  widgetShow window
294
-  widgetShow box
295
-  mainGUI
296
-  return ()

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

@@ -1,137 +0,0 @@
1
-{-# LANGUAGE OverloadedStrings #-}
2
-{-# LANGUAGE ScopedTypeVariables #-}
3
---
4
-module System.Taffybar.Battery (
5
-  batteryBarNew,
6
-  textBatteryNew,
7
-  defaultBatteryConfig
8
-  ) where
9
-
10
-import qualified Control.Exception.Enclosed as E
11
-import Data.Int ( Int64 )
12
-import Data.IORef
13
-import Graphics.UI.Gtk
14
-import qualified System.IO as IO
15
-import Text.Printf ( printf )
16
-import Text.StringTemplate
17
-
18
-import System.Information.Battery
19
-import System.Taffybar.Widgets.PollingBar
20
-import System.Taffybar.Widgets.PollingLabel
21
-
22
-safeGetBatteryInfo :: IORef BatteryContext -> IO (Maybe BatteryInfo)
23
-safeGetBatteryInfo mv = do
24
-  ctxt <- readIORef mv
25
-  E.catchAny (getBatteryInfo ctxt) $ \_ -> reconnect
26
-  where
27
-    reconnect = do
28
-      mctxt <- batteryContextNew
29
-      case mctxt of
30
-        Nothing -> IO.hPutStrLn IO.stderr "Could not reconnect to UPower"
31
-        Just ctxt -> writeIORef mv ctxt
32
-      return Nothing
33
-
34
-battInfo :: IORef BatteryContext -> String -> IO String
35
-battInfo r fmt = do
36
-  minfo <- safeGetBatteryInfo r
37
-  case minfo of
38
-    Nothing -> return ""
39
-    Just info -> do
40
-      let battPctNum :: Int
41
-          battPctNum = floor (batteryPercentage info)
42
-          formatTime :: Int64 -> String
43
-          formatTime seconds =
44
-            let minutes = seconds `div` 60
45
-                hours = minutes `div` 60
46
-                minutes' = minutes `mod` 60
47
-            in printf "%02d:%02d" hours minutes'
48
-
49
-          battTime :: String
50
-          battTime = case (batteryState info) of
51
-            BatteryStateCharging -> (formatTime $ batteryTimeToFull info)
52
-            BatteryStateDischarging -> (formatTime $ batteryTimeToEmpty info)
53
-            _ -> "-"
54
-
55
-          tpl = newSTMP fmt
56
-          tpl' = setManyAttrib [ ("percentage", show battPctNum)
57
-                               , ("time", battTime)
58
-                               ] tpl
59
-      return $ render tpl'
60
-
61
-textBatteryNew :: String    -- ^ Display format
62
-                  -> Double -- ^ Poll period in seconds
63
-                  -> IO Widget
64
-textBatteryNew fmt pollSeconds = do
65
-  battCtxt <- batteryContextNew
66
-  case battCtxt of
67
-    Nothing -> do
68
-      let lbl :: Maybe String
69
-          lbl = Just "No battery"
70
-      labelNew lbl >>= return . toWidget
71
-    Just ctxt -> do
72
-      r <- newIORef ctxt
73
-      l <- pollingLabelNew "" pollSeconds (battInfo r fmt)
74
-      widgetShowAll l
75
-      return l
76
-
77
-battPct :: IORef BatteryContext -> IO Double
78
-battPct r = do
79
-  minfo <- safeGetBatteryInfo r
80
-  case minfo of
81
-    Nothing -> return 0
82
-    Just info -> return (batteryPercentage info / 100)
83
-
84
---
85
-defaultBatteryConfig :: BarConfig
86
-defaultBatteryConfig =
87
-  defaultBarConfig colorFunc
88
-  where
89
-    colorFunc pct
90
-      | pct < 0.1 = (1, 0, 0)
91
-      | pct < 0.9 = (0.5, 0.5, 0.5)
92
-      | otherwise = (0, 1, 0)
93
-
94
-batteryBarNew :: BarConfig -- ^ Configuration options for the bar display
95
-                 -> Double -- ^ Polling period in seconds
96
-                 -> IO Widget
97
-batteryBarNew battCfg pollSeconds = do
98
-  battCtxt <- batteryContextNew
99
-  case battCtxt of
100
-    Nothing -> do
101
-      let lbl :: Maybe String
102
-          lbl = Just "No battery"
103
-      labelNew lbl >>= return . toWidget
104
-    Just ctxt -> do
105
-      -- This is currently pretty inefficient - each poll period it
106
-      -- queries the battery twice (once for the label and once for
107
-      -- the bar).
108
-      --
109
-      -- Converting it to combine the two shouldn't be hard.
110
-      b <- hBoxNew False 1
111
-      txt <- textBatteryNew "$percentage$%" pollSeconds
112
-      r <- newIORef ctxt
113
-      bar <- pollingBarNew battCfg pollSeconds (battPct r)
114
-      boxPackStart b bar PackNatural 0
115
-      boxPackStart b txt PackNatural 0
116
-      widgetShowAll b
117
-      return (toWidget b)

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

@@ -1,40 +0,0 @@
1
---------------------------------------------------------------------------------
2
---
3
---
4
---
5
---------------------------------------------------------------------------------
6
-module System.Taffybar.CPUMonitor where
7
-
8
-import Data.IORef
9
-import Graphics.UI.Gtk
10
-import System.Information.CPU2 (getCPUInfo)
11
-import System.Information.StreamInfo (getAccLoad)
12
-import System.Taffybar.Widgets.PollingGraph
13
-
14
-cpuMonitorNew :: GraphConfig -- ^ Configuration data for the Graph.
15
-              -> Double      -- ^ Polling period (in seconds).
16
-              -> String      -- ^ Name of the core to watch (e.g. \"cpu\", \"cpu0\").
17
-              -> IO Widget
18
-cpuMonitorNew cfg interval cpu = do
19
-    info <- getCPUInfo cpu
20
-    sample <- newIORef info
21
-    pollingGraphNew cfg interval $ probe sample cpu
22
-
23
-probe :: IORef [Int] -> String -> IO [Double]
24
-probe sample cpuName = do
25
-    load <- getAccLoad sample $ getCPUInfo cpuName
26
-    case load of
27
-      l0:l1:l2:_ -> return [ l0 + l1, l2 ] -- user, system
28
-      _ -> return []

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

@@ -1,48 +0,0 @@
1
---------------------------------------------------------------------------------
2
---
3
---
4
---
5
---------------------------------------------------------------------------------
6
-
7
-module System.Taffybar.CommandRunner ( commandRunnerNew ) where
8
-
9
-import qualified Graphics.UI.Gtk                      as Gtk
10
-import           System.Taffybar.Pager                (colorize)
11
-import           System.Taffybar.Widgets.PollingLabel
12
-
13
-import           Control.Monad
14
-import           System.Exit                          (ExitCode (..))
15
-import qualified System.IO as IO
16
-import qualified System.Process as P
17
-
18
-commandRunnerNew :: Double   -- ^ Polling period (in seconds).
19
-                 -> String   -- ^ Command to execute. Should be in $PATH or an absolute path
20
-                 -> [String] -- ^ Command argument. May be @[]@
21
-                 -> String   -- ^ If command fails this will be displayed.
22
-                 -> String   -- ^ Output color
23
-                 -> IO Gtk.Widget
24
-commandRunnerNew interval cmd args defaultOutput color = do
25
-    label  <- pollingLabelNew "" interval $ runCommand cmd args defaultOutput color
26
-    Gtk.widgetShowAll label
27
-    return $ Gtk.toWidget label
28
-
29
-runCommand :: FilePath -> [String] -> String -> String -> IO String
30
-runCommand cmd args defaultOutput color = do
31
-  (ecode, stdout, stderr) <- P.readProcessWithExitCode cmd args ""
32
-  unless (null stderr) $ do
33
-    IO.hPutStrLn IO.stderr stderr
34
-  return $ colorize color "" $ case ecode of
35
-    ExitSuccess -> stdout
36
-    ExitFailure _ -> defaultOutput

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

@@ -1,37 +0,0 @@
1
---------------------------------------------------------------------------------
2
---
3
---
4
---
5
---------------------------------------------------------------------------------
6
-
7
-module System.Taffybar.DiskIOMonitor ( dioMonitorNew ) where
8
-
9
-import qualified Graphics.UI.Gtk as Gtk
10
-import System.Information.DiskIO ( getDiskTransfer )
11
-import System.Taffybar.Widgets.PollingGraph ( GraphConfig, pollingGraphNew )
12
-
13
-dioMonitorNew :: GraphConfig -- ^ Configuration data for the Graph.
14
-              -> Double      -- ^ Polling period (in seconds).
15
-              -> String      -- ^ Name of the disk or partition to watch (e.g. \"sda\", \"sdb1\").
16
-              -> IO Gtk.Widget
17
-dioMonitorNew cfg pollSeconds =
18
-  pollingGraphNew cfg pollSeconds . probeDisk
19
-
20
-probeDisk :: String -> IO [Double]
21
-probeDisk disk = do
22
-  transfer <- getDiskTransfer disk
23
-  let top = foldr max 1.0 transfer
24
-  return $ map (/top) transfer

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

@@ -1,38 +0,0 @@
1
------------------------------------------------------------------------------
2
---
3
---
4
---
5
------------------------------------------------------------------------------
6
-
7
-module System.Taffybar.FSMonitor ( fsMonitorNew ) where
8
-
9
-import qualified Graphics.UI.Gtk as Gtk
10
-import System.Process ( readProcess )
11
-import System.Taffybar.Widgets.PollingLabel ( pollingLabelNew )
12
-
13
-fsMonitorNew :: Double -- ^ Polling interval (in seconds, e.g. 500)
14
-             -> [String] -- ^ Names of the partitions to monitor (e.g. [\"\/\", \"\/home\"])
15
-             -> IO Gtk.Widget
16
-fsMonitorNew interval fsList = do
17
-  label <- pollingLabelNew "" interval $ showFSInfo fsList
18
-  Gtk.widgetShowAll label
19
-  return $ Gtk.toWidget label
20
-
21
-showFSInfo :: [String] -> IO String
22
-showFSInfo fsList = do
23
-  fsOut <- readProcess "df" (["-kP"] ++ fsList) ""
24
-  let fss = map (take 2 . reverse . words) $ drop 1 $ lines fsOut
25
-  return $ unwords $ map ((\s -> "[" ++ s ++ "]") . unwords) fss

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

@@ -1,318 +0,0 @@
1
-{-# LANGUAGE OverloadedStrings #-}
2
-{-# LANGUAGE ScopedTypeVariables #-}
3
---
4
-module System.Taffybar.FreedesktopNotifications (
5
-  -- * Types
6
-  Notification(..),
7
-  NotificationConfig(..),
8
-  -- * Constructor
9
-  notifyAreaNew,
10
-  defaultNotificationConfig
11
-  ) where
12
-
13
-import Control.Concurrent
14
-import Control.Concurrent.STM
15
-import Control.Monad ( forever )
16
-import Control.Monad.Trans ( liftIO )
17
-import Data.Int ( Int32 )
18
-import Data.Map ( Map )
19
-import Data.Monoid ( mconcat )
20
-import qualified Data.Sequence as S
21
-import Data.Sequence ( Seq, (|>), viewl, ViewL(..) )
22
-import Data.Text ( Text )
23
-import qualified Data.Text as T
24
-import Data.Word ( Word32 )
25
-import DBus
26
-import DBus.Client
27
-import Graphics.UI.Gtk hiding ( Variant )
28
-
29
-data Notification = Notification { noteAppName :: Text
30
-                                 , noteReplaceId :: Word32
31
-                                 , noteSummary :: Text
32
-                                 , noteBody :: Text
33
-                                 , noteExpireTimeout :: Int32
34
-                                 , noteId :: Word32
35
-                                 }
36
-                    deriving (Show, Eq)
37
-
38
-data NotifyState = NotifyState { noteWidget :: Label
39
-                               , noteContainer :: Widget
40
-                               , noteConfig :: NotificationConfig
41
-                               , noteQueue :: TVar (Seq Notification)
42
-                                 -- ^ The queue of active (but not yet
43
-                                 -- displayed) notifications
44
-                               , noteIdSource :: TVar Word32
45
-                                 -- ^ A source of new notification ids
46
-                               , noteCurrent :: TVar (Maybe Notification)
47
-                                 -- ^ The current note being displayed
48
-                               , noteChan :: Chan ()
49
-                                 -- ^ Wakes up the GUI update thread
50
-                               }
51
-
52
-initialNoteState :: Widget -> Label -> NotificationConfig -> IO NotifyState
53
-initialNoteState wrapper l cfg = do
54
-  m <- newTVarIO 1
55
-  q <- newTVarIO S.empty
56
-  c <- newTVarIO Nothing
57
-  ch <- newChan
58
-  return NotifyState { noteQueue = q
59
-                     , noteIdSource = m
60
-                     , noteWidget = l
61
-                     , noteContainer = wrapper
62
-                     , noteCurrent = c
63
-                     , noteConfig = cfg
64
-                     , noteChan = ch
65
-                     }
66
-
67
-getServerInformation :: IO (Text, Text, Text, Text)
68
-getServerInformation =
69
-  return ("haskell-notification-daemon",
70
-          "nochair.net",
71
-          "0.0.1",
72
-          "1.1")
73
-
74
-getCapabilities :: IO [Text]
75
-getCapabilities = return ["body", "body-markup"]
76
-
77
-nextNotification :: NotifyState -> STM ()
78
-nextNotification s = do
79
-  q <- readTVar (noteQueue s)
80
-  case viewl q of
81
-    EmptyL -> do
82
-      writeTVar (noteCurrent s) Nothing
83
-    next :< rest -> do
84
-      writeTVar (noteQueue s) rest
85
-      writeTVar (noteCurrent s) (Just next)
86
-
87
-closeNotification :: NotifyState -> Word32 -> IO ()
88
-closeNotification istate nid = do
89
-  atomically $ do
90
-    modifyTVar' (noteQueue istate) removeNote
91
-    curNote <- readTVar (noteCurrent istate)
92
-    case curNote of
93
-      Nothing -> return ()
94
-      Just cnote
95
-        | noteId cnote /= nid -> return ()
96
-        | otherwise ->
97
-          -- in this case, the note was current so we take the next,
98
-          -- if any
99
-          nextNotification istate
100
-  wakeupDisplayThread istate
101
-  where
102
-    removeNote = S.filter (\n -> noteId n /= nid)
103
-
104
-formatMessage :: NotifyState -> Notification -> String
105
-formatMessage s = fmt
106
-  where
107
-    fmt = notificationFormatter $ noteConfig s
108
-
109
---
110
---
111
---
112
-notify :: NotifyState
113
-          -> Text -- ^ Application name
114
-          -> Word32 -- ^ Replaces id
115
-          -> Text -- ^ App icon
116
-          -> Text -- ^ Summary
117
-          -> Text -- ^ Body
118
-          -> [Text] -- ^ Actions
119
-          -> Map Text Variant -- ^ Hints
120
-          -> Int32 -- ^ Expires timeout (milliseconds)
121
-          -> IO Word32
122
-notify istate appName replaceId _ summary body _ _ timeout = do
123
-  nid <- atomically $ do
124
-    tid <- readTVar idsrc
125
-    modifyTVar' idsrc (+1)
126
-    return tid
127
-  let realId = if replaceId == 0 then fromIntegral nid else replaceId
128
-      n = Notification { noteAppName = appName
129
-                       , noteReplaceId = replaceId
130
-                       , noteSummary = escapeText summary
131
-                       , noteBody = escapeText body
132
-                       , noteExpireTimeout = tout
133
-                       , noteId = realId
134
-                       }
135
-  -- If we are replacing an existing note, atomically do the swap in
136
-  -- the note queue and then make this the new current if the queue is
137
-  -- empty OR if the current has this id.
138
-  dn <- atomically $ do
139
-    modifyTVar' (noteQueue istate) (replaceNote n)
140
-    cnote <- readTVar (noteCurrent istate)
141
-    case cnote of
142
-      Nothing -> do
143
-        writeTVar (noteCurrent istate) (Just n)
144
-        return (Just n)
145
-      Just curNote
146
-        | noteId curNote == realId -> do
147
-          writeTVar (noteCurrent istate) (Just n)
148
-          return (Just n)
149
-        | otherwise -> do
150
-          modifyTVar' (noteQueue istate) (|>n)
151
-          return Nothing
152
-  -- This is a little gross - if we added the new notification to the
153
-  -- queue, we can't call displayNote on it because that will
154
-  -- obliterate the current active notification.
155
-  case dn of
156
-    -- take no action; timeout threads will handle it
157
-    Nothing -> return ()
158
-    Just _ -> wakeupDisplayThread istate
159
-  return realId
160
-  where
161
-    replaceNote newNote = fmap (\n -> if noteId n == noteReplaceId newNote then newNote else n)
162
-    idsrc = noteIdSource istate
163
-    escapeText = T.pack . escapeMarkup . T.unpack
164
-    maxtout = fromIntegral $ notificationMaxTimeout (noteConfig istate)
165
-    tout = case timeout of
166
-      0 -> maxtout
167
-      (-1) -> maxtout
168
-      _ -> min maxtout timeout
169
-
170
-notificationDaemon :: (AutoMethod f1, AutoMethod f2)
171
-                      => f1 -> f2 -> IO ()
172
-notificationDaemon onNote onCloseNote = do
173
-  client <- connectSession
174
-  _ <- requestName client "org.freedesktop.Notifications" [nameAllowReplacement, nameReplaceExisting]
175
-  export client "/org/freedesktop/Notifications"
176
-    [ autoMethod "org.freedesktop.Notifications" "GetServerInformation" getServerInformation
177
-    , autoMethod "org.freedesktop.Notifications" "GetCapabilities" getCapabilities
178
-    , autoMethod "org.freedesktop.Notifications" "CloseNotification" onCloseNote
179
-    , autoMethod "org.freedesktop.Notifications" "Notify" onNote
180
-    ]
181
-
182
-wakeupDisplayThread :: NotifyState -> IO ()
183
-wakeupDisplayThread s = writeChan (noteChan s) ()
184
-
185
-displayThread :: NotifyState -> IO ()
186
-displayThread s = forever $ do
187
-  _ <- readChan (noteChan s)
188
-  cur <- atomically $ readTVar (noteCurrent s)
189
-  case cur of
190
-    Nothing -> postGUIAsync (widgetHideAll (noteContainer s))
191
-    Just n -> postGUIAsync $ do
192
-      labelSetMarkup (noteWidget s) (formatMessage s n)
193
-      widgetShowAll (noteContainer s)
194
-      startTimeoutThread s n
195
-
196
-startTimeoutThread :: NotifyState -> Notification -> IO ()
197
-startTimeoutThread s n = do
198
-  _ <- forkIO $ do
199
-    let seconds = noteExpireTimeout n
200
-    threadDelay (fromIntegral seconds * 1000000)
201
-    atomically $ do
202
-      curNote <- readTVar (noteCurrent s)
203
-      case curNote of
204
-        Nothing -> return ()
205
-        Just cnote
206
-          | cnote /= n -> return ()
207
-          | otherwise ->
208
-            -- The note was not invalidated or changed since the timeout
209
-            -- began, so we replace it with the next (if any)
210
-            nextNotification s
211
-    wakeupDisplayThread s
212
-  return ()
213
-
214
-data NotificationConfig =
215
-  NotificationConfig { notificationMaxTimeout :: Int -- ^ Maximum time that a notification will be displayed (in seconds).  Default: 10
216
-                     , notificationMaxLength :: Int  -- ^ Maximum length displayed, in characters.  Default: 50
217
-                     , notificationFormatter :: Notification -> String -- ^ Function used to format notifications
218
-                     }
219
-
220
-defaultFormatter :: Notification -> String
221
-defaultFormatter note = msg
222
-  where
223
-    msg = case T.null (noteBody note) of
224
-      True -> T.unpack $ noteSummary note
225
-      False -> T.unpack $ mconcat [ "<span fgcolor='yellow'>Note:</span>"
226
-                                  , noteSummary note, ": ", noteBody note ]
227
-
228
---
229
---
230
---
231
-defaultNotificationConfig :: NotificationConfig
232
-defaultNotificationConfig =
233
-  NotificationConfig { notificationMaxTimeout = 10
234
-                     , notificationMaxLength = 100
235
-                     , notificationFormatter = defaultFormatter
236
-                     }
237
-
238
-notifyAreaNew :: NotificationConfig -> IO Widget
239
-notifyAreaNew cfg = do
240
-  frame <- frameNew
241
-  box <- hBoxNew False 3
242
-  textArea <- labelNew (Nothing :: Maybe String)
243
-  button <- eventBoxNew
244
-  sep <- vSeparatorNew
245
-
246
-  bLabel <- labelNew (Nothing :: Maybe String)
247
-  widgetSetName bLabel ("NotificationCloseButton" :: String)
248
-  labelSetMarkup bLabel ("×" :: String)
249
-
250
-  labelSetMaxWidthChars textArea (notificationMaxLength cfg)
251
-  labelSetEllipsize textArea EllipsizeEnd
252
-
253
-  containerAdd button bLabel
254
-  boxPackStart box textArea PackGrow 0
255
-  boxPackStart box sep PackNatural 0
256
-  boxPackStart box button PackNatural 0
257
-
258
-  containerAdd frame box
259
-
260
-  widgetHideAll frame
261
-
262
-  istate <- initialNoteState (toWidget frame) textArea cfg
263
-  _ <- on button buttonReleaseEvent (userCancel istate)
264
-
265
-  realizableWrapper <- hBoxNew False 0
266
-  boxPackStart realizableWrapper frame PackNatural 0
267
-  widgetShow realizableWrapper
268
-
269
-  -- We can't start the dbus listener thread until we are in the GTK
270
-  -- main loop, otherwise things are prone to lock up and block
271
-  -- infinitely on an mvar.  Bad stuff - only start the dbus thread
272
-  -- after the fake invisible wrapper widget is realized.
273
-  _ <- on realizableWrapper realize $ do
274
-       _ <- forkIO (displayThread istate)
275
-       notificationDaemon (notify istate) (closeNotification istate)
276
-
277
-  -- Don't show the widget by default - it will appear when needed
278
-  return (toWidget realizableWrapper)
279
-  where
280
-    -- | Close the current note and pull up the next, if any
281
-    userCancel s = do
282
-      liftIO $ do
283
-        atomically $ nextNotification s
284
-        wakeupDisplayThread s
285
-      return True

+ 0
- 76
vendor/taffybar/src/System/Taffybar/Hooks/PagerHints.hs View File

@@ -1,115 +0,0 @@
1
------------------------------------------------------------------------------
2
---
3
---
4
---
5
---
6
---
7
---
8
---
9
------------------------------------------------------------------------------
10
-
11
-module System.Taffybar.Hooks.PagerHints (
12
-  -- * Usage
13
-  -- $usage
14
-  pagerHints
15
-) where
16
-
17
-import Codec.Binary.UTF8.String (encode)
18
-import Control.Monad
19
-import Data.Monoid
20
-import Foreign.C.Types (CInt)
21
-import XMonad
22
-import qualified XMonad.StackSet as W
23
-
24
---
25
---
26
-
27
-xLayoutProp :: X Atom
28
-xLayoutProp = return =<< getAtom "_XMONAD_CURRENT_LAYOUT"
29
-
30
-xVisibleProp :: X Atom
31
-xVisibleProp = return =<< getAtom "_XMONAD_VISIBLE_WORKSPACES"
32
-
33
-pagerHints :: XConfig a -> XConfig a
34
-pagerHints c = c { handleEventHook = handleEventHook c +++ pagerHintsEventHook
35
-           , logHook = logHook c +++ pagerHintsLogHook }
36
-  where x +++ y = x `mappend` y
37
-
38
-pagerHintsLogHook :: X ()
39
-pagerHintsLogHook = do
40
-  withWindowSet
41
-    (setCurrentLayout . description . W.layout . W.workspace . W.current)
42
-  withWindowSet
43
-    (setVisibleWorkspaces . map (W.tag . W.workspace) . W.visible)
44
-
45
-setCurrentLayout :: String -> X ()
46
-setCurrentLayout l = withDisplay $ \dpy -> do
47
-  r <- asks theRoot
48
-  a <- xLayoutProp
49
-  c <- getAtom "UTF8_STRING"
50
-  let l' = map fromIntegral (encode l)
51
-  io $ changeProperty8 dpy r a c propModeReplace l'
52
-
53
-setVisibleWorkspaces :: [String] -> X ()
54
-setVisibleWorkspaces vis = withDisplay $ \dpy -> do
55
-  r  <- asks theRoot
56
-  a  <- xVisibleProp
57
-  c  <- getAtom "UTF8_STRING"
58
-  let vis' = map fromIntegral $ concatMap ((++[0]) . encode) vis
59
-  io $ changeProperty8 dpy r a c propModeReplace vis'
60
-
61
-pagerHintsEventHook :: Event -> X All
62
-pagerHintsEventHook (ClientMessageEvent {
63
-    ev_message_type = mt,
64
-    ev_data = d
65
-  }) = withWindowSet $ \_ -> do
66
-  a <- xLayoutProp
67
-  when (mt == a) $ sendLayoutMessage d
68
-  return (All True)
69
-pagerHintsEventHook _ = return (All True)
70
-
71
-sendLayoutMessage :: [CInt] -> X ()
72
-sendLayoutMessage evData = case evData of
73
-  []   -> return ()
74
-  x:_  -> if x < 0
75
-            then sendMessage FirstLayout
76
-            else sendMessage NextLayout

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

@@ -1,108 +0,0 @@
1
-{-# LANGUAGE ScopedTypeVariables #-}
2
------------------------------------------------------------------------------
3
---
4
---
5
---
6
---
7
------------------------------------------------------------------------------
8
-
9
-module System.Taffybar.LayoutSwitcher (
10
-  -- * Usage
11
-  -- $usage
12
-  layoutSwitcherNew
13
-) where
14
-
15
-import Control.Monad.IO.Class (MonadIO, liftIO)
16
-import qualified Graphics.UI.Gtk as Gtk
17
-import Graphics.X11.Xlib.Extras (Event)
18
-import System.Taffybar.Pager
19
-import System.Information.X11DesktopInfo
20
-import System.Taffybar.Widgets.Util
21
-
22
---
23
---
24
---
25
---
26
---
27
-
28
-xLayoutProp :: String
29
-xLayoutProp = "_XMONAD_CURRENT_LAYOUT"
30
-
31
-layoutSwitcherNew :: Pager -> IO Gtk.Widget
32
-layoutSwitcherNew pager = do
33
-  label <- Gtk.labelNew (Nothing :: Maybe String)
34
-  -- This callback is run in a separate thread and needs to use
35
-  -- postGUIAsync
36
-  let cfg = config pager
37
-      callback = pagerCallback cfg label
38
-  subscribe pager callback xLayoutProp
39
-  assembleWidget label
40
-
41
-pagerCallback :: PagerConfig -> Gtk.Label -> Event -> IO ()
42
-pagerCallback cfg label _ = Gtk.postGUIAsync $ do
43
-  layout <- withDefaultCtx $ readAsString Nothing xLayoutProp
44
-  let decorate = activeLayout cfg
45
-  Gtk.labelSetMarkup label (decorate layout)
46
-
47
-assembleWidget :: Gtk.Label -> IO Gtk.Widget
48
-assembleWidget label = do
49
-  ebox <- Gtk.eventBoxNew
50
-  Gtk.containerAdd ebox label
51
-  _ <- Gtk.on ebox Gtk.buttonPressEvent dispatchButtonEvent
52
-  Gtk.widgetShowAll ebox
53
-  return $ Gtk.toWidget ebox
54
-
55
-dispatchButtonEvent :: Gtk.EventM Gtk.EButton Bool
56
-dispatchButtonEvent = do
57
-  btn <- Gtk.eventButton
58
-  let trigger = onClick [Gtk.SingleClick]
59
-  case btn of
60
-    Gtk.LeftButton  -> trigger $ switch 1
61
-    Gtk.RightButton -> trigger $ switch (-1)
62
-    _               -> return False
63
-
64
-switch :: (MonadIO m) => Int -> m ()
65
-switch n = liftIO $ withDefaultCtx $ do
66
-  cmd <- getAtom xLayoutProp
67
-  sendCommandEvent cmd (fromIntegral n)

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

@@ -1,106 +0,0 @@
1
-{-# LANGUAGE OverloadedStrings #-}
2
-{-# LANGUAGE ScopedTypeVariables #-}
3
-module System.Taffybar.MPRIS
4
-  ( TrackInfo (..)
5
-  , MPRISConfig (..)
6
-  , defaultMPRISConfig
7
-  , mprisNew
8
-  ) where
9
-
10
-import Data.Int ( Int32 )
11
-import qualified Data.Map as M
12
-import Data.Text ( Text )
13
-import qualified Data.Text as T
14
-import DBus
15
-import DBus.Client
16
-import Graphics.UI.Gtk hiding ( Signal, Variant )
17
-import Text.Printf
18
-
19
-data TrackInfo = TrackInfo
20
-  { trackArtist :: Maybe String -- ^ Artist name, if available.
21
-  , trackTitle  :: Maybe String -- ^ Track name, if available.
22
-  , trackAlbum  :: Maybe String -- ^ Album name, if available.
23
-  }
24
-
25
-data MPRISConfig = MPRISConfig
26
-  { trackLabel :: TrackInfo -> String -- ^ Calculate a label to display.
27
-  }
28
-
29
-setupDBus :: MPRISConfig -> Label -> IO ()
30
-setupDBus cfg w = do
31
-  let trackMatcher = matchAny { matchSender = Nothing
32
-                               , matchDestination = Nothing
33
-                               , matchPath = Just "/Player"
34
-                               , matchInterface = Just "org.freedesktop.MediaPlayer"
35
-                               , matchMember = Just "TrackChange"
36
-                               }
37
-      stateMatcher = matchAny { matchSender = Nothing
38
-                               , matchDestination = Nothing
39
-                               , matchPath = Just "/Player"
40
-                               , matchInterface = Just "org.freedesktop.MediaPlayer"
41
-                               , matchMember = Just "StatusChange"
42
-                               }
43
-  client <- connectSession
44
-  listen client trackMatcher (trackCallback cfg w)
45
-  listen client stateMatcher (stateCallback w)
46
-
47
-variantDictLookup :: (IsVariant b, Ord k) => k -> M.Map k Variant -> Maybe b
48
-variantDictLookup k m = do
49
-  val <- M.lookup k m
50
-  fromVariant val
51
-
52
-
53
-trackCallback :: MPRISConfig -> Label -> Signal -> IO ()
54
-trackCallback cfg w s = do
55
-  let v :: Maybe (M.Map Text Variant)
56
-      v = fromVariant variant
57
-      [variant] = signalBody s
58
-  case v of
59
-    Just m -> do
60
-      let getInfo key = fmap (escapeMarkup . T.unpack) $ variantDictLookup key m
61
-          txt = trackLabel cfg info
62
-          info = TrackInfo { trackArtist = getInfo "artist"
63
-                           , trackTitle  = getInfo "title"
64
-                           , trackAlbum  = getInfo "album"
65
-                           }
66
-      postGUIAsync $ do
67
-        -- In case the widget was hidden due to a stop/pause, forcibly
68
-        -- show it again when the track changes.
69
-        labelSetMarkup w txt
70
-        widgetShowAll w
71
-    _ -> return ()
72
-
73
-stateCallback :: Label -> Signal -> IO ()
74
-stateCallback w s =
75
-  case fromVariant (signalBody s !! 0) of
76
-    Just st -> case structureItems st of
77
-      (pstate:_) -> case (fromVariant pstate) :: Maybe Int32 of
78
-        Just 2 -> postGUIAsync $ widgetHideAll w
79
-        Just 1 -> postGUIAsync $ widgetHideAll w
80
-        Just 0 -> postGUIAsync $ widgetShowAll w
81
-        _ -> return ()
82
-      _ -> return ()
83
-    _ -> return ()
84
-
85
-defaultMPRISConfig :: MPRISConfig
86
-defaultMPRISConfig = MPRISConfig
87
-  { trackLabel = display
88
-  }
89
-  where artist track  = maybe "[unknown]" id (trackArtist track)
90
-        title  track  = maybe "[unknown]" id (trackTitle  track)
91
-        display :: TrackInfo -> String
92
-        display track = "<span fgcolor='yellow'>▶</span> " ++
93
-                        printf "%s - %s" (artist track) (title track)
94
-
95
-mprisNew :: MPRISConfig -> IO Widget
96
-mprisNew cfg = do
97
-  l <- labelNew (Nothing :: Maybe String)
98
-
99
-  _ <- on l realize $ setupDBus cfg l
100
-  widgetShowAll l
101
-  return (toWidget l)

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

@@ -1,126 +0,0 @@
1
-{-# LANGUAGE OverloadedStrings #-}
2
-{-# LANGUAGE ScopedTypeVariables #-}
3
---
4
-module System.Taffybar.MPRIS2 ( mpris2New ) where
5
-
6
-import Data.Maybe ( listToMaybe )
7
-import DBus
8
-import DBus.Client
9
-import Data.List (isPrefixOf)
10
-import Graphics.UI.Gtk hiding ( Signal, Variant )
11
-import Text.Printf
12
-
13
-mpris2New :: IO Widget
14
-mpris2New = do
15
-  label <- labelNew (Nothing :: Maybe String)
16
-  widgetShowAll label
17
-  _ <- on label realize $ initLabel label
18
-  return (toWidget label)
19
-
20
-unpack :: IsVariant a => Variant -> a
21
-unpack var = case fromVariant var of
22
-  Just x -> x
23
-  Nothing -> error("Could not unpack variant: " ++ show var)
24
-
25
-initLabel :: Label -> IO ()
26
-initLabel w = do
27
-  client <- connectSession
28
-  -- Set initial song state/info
29
-  reqSongInfo w client
30
-  listen client propMatcher (callBack w)
31
-  return ()
32
-    where callBack label s = do
33
-            let items = dictionaryItems $ unpack (signalBody s !! 1)
34
-            updatePlaybackStatus label items
35
-            updateMetadata label items
36
-            return ()
37
-          propMatcher = matchAny { matchSender = Nothing
38
-                                 , matchDestination = Nothing
39
-                                 , matchPath = Just "/org/mpris/MediaPlayer2"
40
-                                 , matchInterface = Just "org.freedesktop.DBus.Properties"
41
-                                 , matchMember = Just "PropertiesChanged"
42
-                                 }
43
-
44
-reqSongInfo :: Label -> Client -> IO ()
45
-reqSongInfo w client = do
46
-  rep <- call_ client (methodCall "/org/freedesktop/DBus" "org.freedesktop.DBus" "ListNames")
47
-                         { methodCallDestination = Just "org.freedesktop.DBus" }
48
-  let plist = unpack $ methodReturnBody rep !! 0
49
-  let players = filter (isPrefixOf "org.mpris.MediaPlayer2.") plist
50
-  case length players of
51
-    0 -> return ()
52
-    _ -> do
53
-      reply <- getProperty client (players !! 0) "Metadata"
54
-      updateSongInfo w $ dictionaryItems $ (unpack . unpack) (methodReturnBody reply !! 0)
55
-      reply' <- getProperty client (players !! 0) "PlaybackStatus"
56
-      let status = (unpack . unpack) (methodReturnBody reply' !! 0) :: String
57
-      case status of
58
-        "Playing" -> postGUIAsync $ widgetShowAll w
59
-        "Paused"  -> postGUIAsync $ widgetHideAll w
60
-        "Stopped" -> postGUIAsync $ widgetHideAll w
61
-        _         -> return ()
62
-
63
-getProperty :: Client -> String -> String -> IO MethodReturn
64
-getProperty client name property = do
65
-  call_ client (methodCall "/org/mpris/MediaPlayer2" "org.freedesktop.DBus.Properties" "Get")
66
-    { methodCallDestination = Just (busName_ name)
67
-    , methodCallBody = [ toVariant ("org.mpris.MediaPlayer2.Player" :: String),
68
-                         toVariant property ]
69
-    }
70
-
71
-setSongInfo :: Label -> String -> String -> IO ()
72
-setSongInfo w artist title = do
73
-  let msg :: String
74
-      msg = case artist of
75
-        "" -> escapeMarkup $ printf "%s" (truncateString 30 title)
76
-        _ ->  escapeMarkup $ printf "%s - %s" (truncateString 15 artist) (truncateString 30 title)
77
-      txt = "<span fgcolor='yellow'>▶</span> " ++ msg
78
-  postGUIAsync $ do
79
-    labelSetMarkup w txt
80
-
81
-truncateString :: Int -> String -> String
82
-truncateString n xs | length xs <= n = xs
83
-              | otherwise      = take n xs ++ "…"
84
-