-----------------------------------------------------------------------------
-- |
-- 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 $ defaultConfig
-- > ...

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

-- | The \"Visible Workspaces\" custom hint.
xVisibleProp :: X Atom
xVisibleProp :: X Atom
xVisibleProp = String -> X Atom
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 :: XConfig a -> XConfig a
pagerHints XConfig a
c =
  XConfig a
c { handleEventHook :: Event -> X All
handleEventHook = XConfig a -> Event -> X All
forall (l :: * -> *). XConfig l -> Event -> X All
handleEventHook XConfig a
c (Event -> X All) -> (Event -> X All) -> Event -> X All
forall a. Semigroup a => a -> a -> a
<> Event -> X All
pagerHintsEventHook
    , logHook :: X ()
logHook = XConfig a -> X ()
forall (l :: * -> *). XConfig l -> X ()
logHook XConfig a
c X () -> X () -> X ()
forall a. Semigroup a => a -> a -> a
<> X ()
pagerHintsLogHook
    }

-- | Update the current values of both custom hints.
pagerHintsLogHook :: X ()
pagerHintsLogHook :: X ()
pagerHintsLogHook = do
  (WindowSet -> X ()) -> X ()
forall a. (WindowSet -> X a) -> X a
withWindowSet
    (String -> X ()
setCurrentLayoutProp (String -> X ()) -> (WindowSet -> String) -> WindowSet -> X ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Layout Atom -> String
forall (layout :: * -> *) a.
LayoutClass layout a =>
layout a -> String
description (Layout Atom -> String)
-> (WindowSet -> Layout Atom) -> WindowSet -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Workspace String (Layout Atom) Atom -> Layout Atom
forall i l a. Workspace i l a -> l
W.layout (Workspace String (Layout Atom) Atom -> Layout Atom)
-> (WindowSet -> Workspace String (Layout Atom) Atom)
-> WindowSet
-> Layout Atom
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Screen String (Layout Atom) Atom ScreenId ScreenDetail
-> Workspace String (Layout Atom) Atom
forall i l a sid sd. Screen i l a sid sd -> Workspace i l a
W.workspace (Screen String (Layout Atom) Atom ScreenId ScreenDetail
 -> Workspace String (Layout Atom) Atom)
-> (WindowSet
    -> Screen String (Layout Atom) Atom ScreenId ScreenDetail)
-> WindowSet
-> Workspace String (Layout Atom) Atom
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WindowSet -> Screen String (Layout Atom) Atom ScreenId ScreenDetail
forall i l a sid sd. StackSet i l a sid sd -> Screen i l a sid sd
W.current)
  (WindowSet -> X ()) -> X ()
forall a. (WindowSet -> X a) -> X a
withWindowSet
    ([String] -> X ()
setVisibleWorkspacesProp ([String] -> X ()) -> (WindowSet -> [String]) -> WindowSet -> X ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Screen String (Layout Atom) Atom ScreenId ScreenDetail -> String)
-> [Screen String (Layout Atom) Atom ScreenId ScreenDetail]
-> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Workspace String (Layout Atom) Atom -> String
forall i l a. Workspace i l a -> i
W.tag (Workspace String (Layout Atom) Atom -> String)
-> (Screen String (Layout Atom) Atom ScreenId ScreenDetail
    -> Workspace String (Layout Atom) Atom)
-> Screen String (Layout Atom) Atom ScreenId ScreenDetail
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Screen String (Layout Atom) Atom ScreenId ScreenDetail
-> Workspace String (Layout Atom) Atom
forall i l a sid sd. Screen i l a sid sd -> Workspace i l a
W.workspace) ([Screen String (Layout Atom) Atom ScreenId ScreenDetail]
 -> [String])
-> (WindowSet
    -> [Screen String (Layout Atom) Atom ScreenId ScreenDetail])
-> WindowSet
-> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WindowSet
-> [Screen String (Layout Atom) Atom ScreenId ScreenDetail]
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 = (Display -> X ()) -> X ()
forall a. (Display -> X a) -> X a
withDisplay ((Display -> X ()) -> X ()) -> (Display -> X ()) -> X ()
forall a b. (a -> b) -> a -> b
$ \Display
dpy -> do
  Atom
r <- (XConf -> Atom) -> X Atom
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XConf -> Atom
theRoot
  Atom
a <- X Atom
xLayoutProp
  Atom
c <- String -> X Atom
getAtom String
"UTF8_STRING"
  let l' :: [CChar]
l' = (Word8 -> CChar) -> [Word8] -> [CChar]
forall a b. (a -> b) -> [a] -> [b]
map Word8 -> CChar
forall a b. (Integral a, Num b) => a -> b
fromIntegral (String -> [Word8]
encode String
l)
  IO () -> X ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> X ()) -> IO () -> X ()
forall a b. (a -> b) -> a -> b
$ Display -> Atom -> Atom -> Atom -> CInt -> [CChar] -> IO ()
changeProperty8 Display
dpy Atom
r Atom
a Atom
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 = (Display -> X ()) -> X ()
forall a. (Display -> X a) -> X a
withDisplay ((Display -> X ()) -> X ()) -> (Display -> X ()) -> X ()
forall a b. (a -> b) -> a -> b
$ \Display
dpy -> do
  Atom
r  <- (XConf -> Atom) -> X Atom
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XConf -> Atom
theRoot
  Atom
a  <- X Atom
xVisibleProp
  Atom
c  <- String -> X Atom
getAtom String
"UTF8_STRING"
  let vis' :: [CChar]
vis' = (Word8 -> CChar) -> [Word8] -> [CChar]
forall a b. (a -> b) -> [a] -> [b]
map Word8 -> CChar
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([Word8] -> [CChar]) -> [Word8] -> [CChar]
forall a b. (a -> b) -> a -> b
$ (String -> [Word8]) -> [String] -> [Word8]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (([Word8] -> [Word8] -> [Word8]
forall a. [a] -> [a] -> [a]
++[Word8
0]) ([Word8] -> [Word8]) -> (String -> [Word8]) -> String -> [Word8]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [Word8]
encode) [String]
vis
  IO () -> X ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> X ()) -> IO () -> X ()
forall a b. (a -> b) -> a -> b
$ Display -> Atom -> Atom -> Atom -> CInt -> [CChar] -> IO ()
changeProperty8 Display
dpy Atom
r Atom
a Atom
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 -> Atom
ev_message_type = Atom
mt
                      , ev_data :: Event -> [CInt]
ev_data = [CInt]
d
                      } = (WindowSet -> X All) -> X All
forall a. (WindowSet -> X a) -> X a
withWindowSet ((WindowSet -> X All) -> X All) -> (WindowSet -> X All) -> X All
forall a b. (a -> b) -> a -> b
$ \WindowSet
_ -> do
  Atom
a <- X Atom
xLayoutProp
  Bool -> X () -> X ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Atom
mt Atom -> Atom -> Bool
forall a. Eq a => a -> a -> Bool
== Atom
a) (X () -> X ()) -> X () -> X ()
forall a b. (a -> b) -> a -> b
$ [CInt] -> X ()
sendLayoutMessage [CInt]
d
  All -> X All
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> All
All Bool
True)
pagerHintsEventHook Event
_ = All -> X All
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 CInt -> CInt -> Bool
forall a. Ord a => a -> a -> Bool
< CInt
0     = ChangeLayout -> X ()
forall a. Message a => a -> X ()
sendMessage ChangeLayout
FirstLayout
                        | Bool
otherwise = ChangeLayout -> X ()
forall a. Message a => a -> X ()
sendMessage ChangeLayout
NextLayout
sendLayoutMessage [] = () -> X ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()