-----------------------------------------------------------------------------
-- |
-- Module      : System.Taffybar.Support.PagerHints
-- Copyright   : (c) José A. Romero L.
-- License     : BSD3-style (see LICENSE)
--
-- Maintainer  : José A. Romero L. <escherdragon@gmail.com>
-- Stability   : unstable
-- Portability : unportable
--
-- Complements the "XMonad.Hooks.EwmhDesktops" with two additional hints
-- not contemplated by the EWMH standard:
--
-- [@_XMONAD_CURRENT_LAYOUT@] Contains a UTF-8 string with the name of the
-- windows layout currently used in the active workspace.
--
-- [@_XMONAD_VISIBLE_WORKSPACES@] Contains a list of UTF-8 strings with the
-- names of all the workspaces that are currently showed in a secondary
-- display, or an empty list if in the current installation there's only
-- one monitor.
--
-- The first hint can be set directly on the root window of the default
-- display, or indirectly via X11 events with an atom of the same
-- name. This allows both to track any changes that occur in the layout of
-- the current workspace, as well as to have it changed automatically by
-- just sending a custom event to the hook.
--
-- The second one should be considered read-only, and is set every time
-- XMonad calls its log hooks.
--
-----------------------------------------------------------------------------

module System.Taffybar.Support.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.Support.PagerHints (pagerHints)
-- >
-- > main = xmonad $ ewmh $ pagerHints $ defaultConfig
-- > ...

-- | 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 = 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}. Monoid 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}. Monoid a => a -> a -> a
+++ X ()
pagerHintsLogHook }
  where a
x +++ :: a -> a -> a
+++ a
y = a
x a -> a -> a
forall {a}. Monoid a => a -> a -> a
`mappend` a
y

-- | 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 ()
setCurrentLayout (String -> X ()) -> (WindowSet -> String) -> WindowSet -> X ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Layout Window -> String
forall (layout :: * -> *) a.
LayoutClass layout a =>
layout a -> String
description (Layout Window -> String)
-> (WindowSet -> Layout Window) -> WindowSet -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Workspace String (Layout Window) Window -> Layout Window
forall i l a. Workspace i l a -> l
W.layout (Workspace String (Layout Window) Window -> Layout Window)
-> (WindowSet -> Workspace String (Layout Window) Window)
-> WindowSet
-> Layout Window
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Screen String (Layout Window) Window ScreenId ScreenDetail
-> Workspace String (Layout Window) Window
forall i l a sid sd. Screen i l a sid sd -> Workspace i l a
W.workspace (Screen String (Layout Window) Window ScreenId ScreenDetail
 -> Workspace String (Layout Window) Window)
-> (WindowSet
    -> Screen String (Layout Window) Window ScreenId ScreenDetail)
-> WindowSet
-> Workspace String (Layout Window) Window
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WindowSet
-> Screen String (Layout Window) Window 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 ()
setVisibleWorkspaces ([String] -> X ()) -> (WindowSet -> [String]) -> WindowSet -> X ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Screen String (Layout Window) Window ScreenId ScreenDetail
 -> String)
-> [Screen String (Layout Window) Window ScreenId ScreenDetail]
-> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Workspace String (Layout Window) Window -> String
forall i l a. Workspace i l a -> i
W.tag (Workspace String (Layout Window) Window -> String)
-> (Screen String (Layout Window) Window ScreenId ScreenDetail
    -> Workspace String (Layout Window) Window)
-> Screen String (Layout Window) Window ScreenId ScreenDetail
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Screen String (Layout Window) Window ScreenId ScreenDetail
-> Workspace String (Layout Window) Window
forall i l a sid sd. Screen i l a sid sd -> Workspace i l a
W.workspace) ([Screen String (Layout Window) Window ScreenId ScreenDetail]
 -> [String])
-> (WindowSet
    -> [Screen String (Layout Window) Window ScreenId ScreenDetail])
-> WindowSet
-> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WindowSet
-> [Screen String (Layout Window) Window 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.
setCurrentLayout :: String -> X ()
setCurrentLayout :: String -> X ()
setCurrentLayout 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
  Window
r <- (XConf -> Window) -> X Window
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' = (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 -> 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.
setVisibleWorkspaces :: [String] -> X ()
setVisibleWorkspaces :: [String] -> X ()
setVisibleWorkspaces [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
  Window
r  <- (XConf -> Window) -> X Window
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' = (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 -> 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
  } = (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
  Window
a <- X Window
xLayoutProp
  Bool -> X () -> X ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Window
mt Window -> Window -> Bool
forall a. Eq a => a -> a -> Bool
== Window
a) (X () -> X ()) -> X () -> X ()
forall a b. (a -> b) -> a -> b
$ [CInt] -> X ()
sendLayoutMessage [CInt]
d
  All -> X All
forall a. a -> X a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> All
All Bool
True)
pagerHintsEventHook Event
_ = All -> X All
forall a. a -> X a
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]
evData = case [CInt]
evData of
  []   -> () -> X ()
forall a. a -> X a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  CInt
x:[CInt]
_  -> if CInt
x CInt -> CInt -> Bool
forall a. Ord a => a -> a -> Bool
< CInt
0
            then ChangeLayout -> X ()
forall a. Message a => a -> X ()
sendMessage ChangeLayout
FirstLayout
            else ChangeLayout -> X ()
forall a. Message a => a -> X ()
sendMessage ChangeLayout
NextLayout