module XMonad.Hooks.TaffybarPagerHints (
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
xLayoutProp :: X Atom
xLayoutProp :: X Window
xLayoutProp = String -> X Window
getAtom String
"_XMONAD_CURRENT_LAYOUT"
xVisibleProp :: X Atom
xVisibleProp :: X Window
xVisibleProp = String -> X Window
getAtom String
"_XMONAD_VISIBLE_WORKSPACES"
pagerHints :: XConfig a -> XConfig a
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
}
pagerHintsLogHook :: X ()
= 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)
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'
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'
pagerHintsEventHook :: Event -> X All
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)
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 ()