Merge branch 'addTaffybarPagerHints'

CHANGES.md

@@ -130,6 +130,11 @@
 
 ### New Modules
 
+  * `XMonad.Hooks.TaffybarPagerHints`
+
+    Add a module that exports information about XMonads internal state that is
+    not available through EWMH that is used by the taffybar status bar.
+
   * `XMonad.Hooks.StatusBar.PP`
 
     Originally contained inside `XMonad.Hooks.DynamicLog`, this module provides the

XMonad/Doc/Extending.hs

@@ -578,6 +578,11 @@ Here is a list of the modules found in @XMonad.Hooks@:
         pretty-printing abstraction 'XMonad.Hooks.StatusBar.PP.PP' and a set
         of functions to interact with it.
 
+* "XMonad.Hooks.TaffybarPagerHints"
+    This module exports additional X properties that allow
+    [taffybar](https://github.com/taffybar/taffybar) to understand the state of
+    XMonad.
+
 * "XMonad.Hooks.ToggleHook":
     Hook and keybindings for toggling hook behavior.
 

XMonad/Hooks/TaffybarPagerHints.hs

@@ -0,0 +1,102 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  XMonad.Util.TaffybarPagerHints
+-- Copyright   :  (c) 2020 Ivan Malison
+-- License     :  BSD3-style (see LICENSE)
+--
+-- Maintainer  :  Ivan Malison <[email protected]>
+-- Stability   :  unstable
+-- Portability :  unportable
+--
+-- This module exports additional X properties that allow
+-- [taffybar](https://github.com/taffybar/taffybar) to understand the state of
+-- XMonad.
+--
+-----------------------------------------------------------------------------
+
+module XMonad.Hooks.TaffybarPagerHints (
+    -- $usage
+    pagerHints,
+    pagerHintsLogHook,
+    pagerHintsEventHook,
+
+    setCurrentLayoutProp,
+    setVisibleWorkspacesProp,
+    ) where
+
+import Codec.Binary.UTF8.String (encode)
+import Foreign.C.Types (CInt)
+
+import XMonad
+import XMonad.Prelude
+import qualified XMonad.StackSet as W
+
+-- $usage
+--
+-- You can use this module with the following in your @xmonad.hs@ file:
+--
+-- > import XMonad.Hooks.TaffybarPagerHints (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
+    }
+
+-- | Update the current values of both custom hints.
+pagerHintsLogHook :: X ()
+pagerHintsLogHook = do
+  withWindowSet
+    (setCurrentLayoutProp . description . W.layout . W.workspace . W.current)
+  withWindowSet
+    (setVisibleWorkspacesProp . map (W.tag . W.workspace) . W.visible)
+
+-- | Set the value of the \"Current Layout\" custom hint to the one given.
+setCurrentLayoutProp :: String -> X ()
+setCurrentLayoutProp 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.
+setVisibleWorkspacesProp :: [String] -> X ()
+setVisibleWorkspacesProp 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 (x:_) | x < 0     = sendMessage FirstLayout
+                        | otherwise = sendMessage NextLayout
+sendLayoutMessage [] = return ()

xmonad-contrib.cabal

@@ -192,6 +192,7 @@ library
                         XMonad.Hooks.SetWMName
                         XMonad.Hooks.StatusBar
                         XMonad.Hooks.StatusBar.PP
+                        XMonad.Hooks.TaffybarPagerHints
                         XMonad.Hooks.ToggleHook
                         XMonad.Hooks.UrgencyHook
                         XMonad.Hooks.WallpaperSetter