[XMonad] Add pager hints from taffybar as source file

This avoids adding taffybar and all of dependencies as a dependency for my
xmonad config.

dotfiles/config/xmonad/src/PagerHints.hs

@@ -0,0 +1,83 @@
+module PagerHints (
+  -- * Usage
+  -- $usage
+  pagerHints
+) where
+
+import Codec.Binary.UTF8.String (encode)
+import Control.Monad
+import Data.Monoid
+import Foreign.C.Types (CInt)
+import XMonad
+import qualified XMonad.StackSet as W
+
+-- $usage
+--
+-- You can use this module with the following in your @xmonad.hs@ file:
+--
+-- > import System.Taffybar.Hooks.PagerHints (pagerHints)
+-- >
+-- > main = xmonad $ ewmh $ pagerHints $ defaultConfig
+-- > ...
+
+-- | The \"Current Layout\" custom hint.
+xLayoutProp :: X Atom
+xLayoutProp = getAtom "_XMONAD_CURRENT_LAYOUT"
+
+-- | The \"Visible Workspaces\" custom hint.
+xVisibleProp :: X Atom
+xVisibleProp = getAtom "_XMONAD_VISIBLE_WORKSPACES"
+
+-- | Add support for the \"Current Layout\" and \"Visible Workspaces\" custom
+-- hints to the given config.
+pagerHints :: XConfig a -> XConfig a
+pagerHints c = c { handleEventHook = handleEventHook c +++ pagerHintsEventHook
+           , logHook = logHook c +++ pagerHintsLogHook }
+  where x +++ y = x `mappend` y
+
+-- | Update the current values of both custom hints.
+pagerHintsLogHook :: X ()
+pagerHintsLogHook = do
+  withWindowSet
+    (setCurrentLayout . description . W.layout . W.workspace . W.current)
+  withWindowSet
+    (setVisibleWorkspaces . map (W.tag . W.workspace) . W.visible)
+
+-- | Set the value of the \"Current Layout\" custom hint to the one given.
+setCurrentLayout :: String -> X ()
+setCurrentLayout l = withDisplay $ \dpy -> do
+  r <- asks theRoot
+  a <- xLayoutProp
+  c <- getAtom "UTF8_STRING"
+  let l' = map fromIntegral (encode l)
+  io $ changeProperty8 dpy r a c propModeReplace l'
+
+-- | Set the value of the \"Visible Workspaces\" hint to the one given.
+setVisibleWorkspaces :: [String] -> X ()
+setVisibleWorkspaces vis = withDisplay $ \dpy -> do
+  r  <- asks theRoot
+  a  <- xVisibleProp
+  c  <- getAtom "UTF8_STRING"
+  let vis' = map fromIntegral $ concatMap ((++[0]) . encode) vis
+  io $ changeProperty8 dpy r a c propModeReplace vis'
+
+-- | Handle all \"Current Layout\" events received from pager widgets, and
+-- set the current layout accordingly.
+pagerHintsEventHook :: Event -> X All
+pagerHintsEventHook ClientMessageEvent {
+    ev_message_type = mt,
+    ev_data = d
+  } = withWindowSet $ \_ -> do
+  a <- xLayoutProp
+  when (mt == a) $ sendLayoutMessage d
+  return (All True)
+pagerHintsEventHook _ = return (All True)
+
+-- | Request a change in the current layout by sending an internal message
+-- to XMonad.
+sendLayoutMessage :: [CInt] -> X ()
+sendLayoutMessage evData = case evData of
+  []   -> return ()
+  x:_  -> if x < 0
+            then sendMessage FirstLayout
+            else sendMessage NextLayout

dotfiles/config/xmonad/stack.yaml

@@ -6,33 +6,6 @@ packages:
   extra-dep: true
 - location: ./xmonad-contrib
   extra-dep: true
-- location: ./taffybar
-  extra-dep: true
 extra-deps:
 - X11-xft-0.3.1
-- alsa-mixer-0.2.0.3
-- dbus-1.0.1
-- dbus-hslogger-0.1.0.1
-- gi-dbusmenu-0.4.1
-- gi-dbusmenugtk3-0.4.1
-- gi-gdk-3.0.15
-- gi-gdkpixbuf-2.0.16
-- gi-gdkx11-3.0.2
-- gi-gio-2.0.18
-- gi-gtk-3.0.22
-- gi-pango-1.0.16
-- gi-xlib-2.0.2
-- gio-0.13.5.0
-- gtk-sni-tray-0.1.2.0
-- gtk-strut-0.1.2.0
-- gtk-traymanager-1.0.1
-- gtk3-0.14.9
-- haskell-gi-0.21.2
-- haskell-gi-base-0.21.1
-- libxml-sax-0.7.5
-- rate-limit-1.1.1
-- spool-0.1
-- status-notifier-item-0.2.1.0
-- time-units-1.0.0
-- xml-helpers-1.0.0
 resolver: lts-11.7

dotfiles/config/xmonad/xmonad.hs

@@ -24,7 +24,7 @@ import           Network.HostName
 import           System.Directory
 import           System.FilePath.Posix
 import           System.Process
-import           System.Taffybar.Hooks.PagerHints
+import           PagerHints
 import           Text.Printf
 import           Unsafe.Coerce