-----------------------------------------------------------------------------
-- |
-- Module      :  XMonad.Hooks.TaffybarPagerHints
-- Description :  Export additional X properties for [taffybar](https://github.com/taffybar/taffybar).
-- Copyright   :  (c) 2020 Ivan Malison
-- License     :  BSD3-style (see LICENSE)
--
-- Maintainer  :  Ivan Malison <ivanmalison@gmail.com>
-- 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 $ def
-- > ...

-- | The \"Current Layout\" custom hint.
xLayoutProp :: X Atom
xLayoutProp :: X Window
xLayoutProp = String -> X Window
getAtom String
"_XMONAD_CURRENT_LAYOUT"

-- | The \"Visible Workspaces\" custom hint.
xVisibleProp :: X Atom
xVisibleProp :: X Window
xVisibleProp = String -> X Window
getAtom String
"_XMONAD_VISIBLE_WORKSPACES"

-- | Add support for the \"Current Layout\" and \"Visible Workspaces\" custom
-- hints to the given config.
pagerHints :: XConfig a -> XConfig a
pagerHints :: forall (a :: * -> *). XConfig a -> XConfig a
pagerHints XConfig a
c =
  XConfig a
c { handleEventHook :: Event -> X All
handleEventHook = forall (l :: * -> *). XConfig l -> Event -> X All
handleEventHook XConfig a
c forall a. Semigroup a => a -> a -> a
<> Event -> X All
pagerHintsEventHook
    , logHook :: X ()
logHook = forall (l :: * -> *). XConfig l -> X ()
logHook XConfig a
c forall a. Semigroup a => a -> a -> a
<> X ()
pagerHintsLogHook
    }

-- | Update the current values of both custom hints.
pagerHintsLogHook :: X ()
pagerHintsLogHook :: X ()
pagerHintsLogHook = do
  forall a. (WindowSet -> X a) -> X a
withWindowSet
    (String -> X ()
setCurrentLayoutProp forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (layout :: * -> *) a.
LayoutClass layout a =>
layout a -> String
description forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall i l a. Workspace i l a -> l
W.layout forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall i l a sid sd. Screen i l a sid sd -> Workspace i l a
W.workspace forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall i l a sid sd. StackSet i l a sid sd -> Screen i l a sid sd
W.current)
  forall a. (WindowSet -> X a) -> X a
withWindowSet
    ([String] -> X ()
setVisibleWorkspacesProp forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall i l a. Workspace i l a -> i
W.tag forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall i l a sid sd. Screen i l a sid sd -> Workspace i l a
W.workspace) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall i l a sid sd. StackSet i l a sid sd -> [Screen i l a sid sd]
W.visible)

-- | Set the value of the \"Current Layout\" custom hint to the one given.
setCurrentLayoutProp :: String -> X ()
setCurrentLayoutProp :: String -> X ()
setCurrentLayoutProp String
l = forall a. (Display -> X a) -> X a
withDisplay forall a b. (a -> b) -> a -> b
$ \Display
dpy -> do
  Window
r <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XConf -> Window
theRoot
  Window
a <- X Window
xLayoutProp
  Window
c <- String -> X Window
getAtom String
"UTF8_STRING"
  let l' :: [CChar]
l' = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (Integral a, Num b) => a -> b
fromIntegral (String -> [Word8]
encode String
l)
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ Display -> Window -> Window -> Window -> CInt -> [CChar] -> IO ()
changeProperty8 Display
dpy Window
r Window
a Window
c CInt
propModeReplace [CChar]
l'

-- | Set the value of the \"Visible Workspaces\" hint to the one given.
setVisibleWorkspacesProp :: [String] -> X ()
setVisibleWorkspacesProp :: [String] -> X ()
setVisibleWorkspacesProp [String]
vis = forall a. (Display -> X a) -> X a
withDisplay forall a b. (a -> b) -> a -> b
$ \Display
dpy -> do
  Window
r  <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XConf -> Window
theRoot
  Window
a  <- X Window
xVisibleProp
  Window
c  <- String -> X Window
getAtom String
"UTF8_STRING"
  let vis' :: [CChar]
vis' = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((forall a. [a] -> [a] -> [a]
++[Word8
0]) forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [Word8]
encode) [String]
vis
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ Display -> Window -> Window -> Window -> CInt -> [CChar] -> IO ()
changeProperty8 Display
dpy Window
r Window
a Window
c CInt
propModeReplace [CChar]
vis'

-- | Handle all \"Current Layout\" events received from pager widgets, and
-- set the current layout accordingly.
pagerHintsEventHook :: Event -> X All
pagerHintsEventHook :: Event -> X All
pagerHintsEventHook ClientMessageEvent
                      { ev_message_type :: Event -> Window
ev_message_type = Window
mt
                      , ev_data :: Event -> [CInt]
ev_data = [CInt]
d
                      } = forall a. (WindowSet -> X a) -> X a
withWindowSet forall a b. (a -> b) -> a -> b
$ \WindowSet
_ -> do
  Window
a <- X Window
xLayoutProp
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Window
mt forall a. Eq a => a -> a -> Bool
== Window
a) forall a b. (a -> b) -> a -> b
$ [CInt] -> X ()
sendLayoutMessage [CInt]
d
  forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> All
All Bool
True)
pagerHintsEventHook Event
_ = forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> All
All Bool
True)

-- | Request a change in the current layout by sending an internal message
-- to XMonad.
sendLayoutMessage :: [CInt] -> X ()
sendLayoutMessage :: [CInt] -> X ()
sendLayoutMessage (CInt
x:[CInt]
_) | CInt
x forall a. Ord a => a -> a -> Bool
< CInt
0     = forall a. Message a => a -> X ()
sendMessage ChangeLayout
FirstLayout
                        | Bool
otherwise = forall a. Message a => a -> X ()
sendMessage ChangeLayout
NextLayout
sendLayoutMessage [] = forall (m :: * -> *) a. Monad m => a -> m a
return ()