module System.Information.X11DesktopInfo
( X11Context
, X11Property
, X11Window
, withDefaultCtx
, readAsInt
, readAsString
, readAsListOfString
, readAsListOfWindow
, isWindowUrgent
, getVisibleTags
, getAtom
, eventLoop
, sendCommandEvent
, sendWindowEvent
) where
import Codec.Binary.UTF8.String as UTF8
import Control.Monad.Reader
import Data.Bits (testBit, (.|.))
import Data.List.Split (endBy)
import Data.Maybe (fromMaybe)
import Graphics.X11.Xlib
import Graphics.X11.Xlib.Extras
data X11Context = X11Context { contextDisplay :: Display, contextRoot :: Window }
type X11Property a = ReaderT X11Context IO a
type X11Window = Window
type PropertyFetcher a = Display -> Atom -> Window -> IO (Maybe [a])
withDefaultCtx :: X11Property a -> IO a
withDefaultCtx fun = do
ctx <- getDefaultCtx
res <- runReaderT fun ctx
closeDisplay (contextDisplay ctx)
return res
readAsInt :: Maybe X11Window
-> String
-> X11Property Int
readAsInt window name = do
prop <- fetch getWindowProperty32 window name
case prop of
Just (x:_) -> return (fromIntegral x)
_ -> return (1)
readAsString :: Maybe X11Window
-> String
-> X11Property String
readAsString window name = do
prop <- fetch getWindowProperty8 window name
case prop of
Just xs -> return . UTF8.decode . map fromIntegral $ xs
_ -> return []
readAsListOfString :: Maybe X11Window
-> String
-> X11Property [String]
readAsListOfString window name = do
prop <- fetch getWindowProperty8 window name
case prop of
Just xs -> return (parse xs)
_ -> return []
where
parse = endBy "\0" . UTF8.decode . map fromIntegral
readAsListOfWindow :: Maybe X11Window
-> String
-> X11Property [X11Window]
readAsListOfWindow window name = do
prop <- fetch getWindowProperty32 window name
case prop of
Just xs -> return $ map fromIntegral xs
_ -> return []
isWindowUrgent :: X11Window -> X11Property Bool
isWindowUrgent window = do
hints <- fetchWindowHints window
return $ testBit (wmh_flags hints) urgencyHintBit
getVisibleTags :: X11Property [String]
getVisibleTags = return =<<
readAsListOfString Nothing "_XMONAD_VISIBLE_WORKSPACES"
getAtom :: String -> X11Property Atom
getAtom s = do
(X11Context d _) <- ask
atom <- liftIO $ internAtom d s False
return atom
eventLoop :: (Event -> IO ()) -> X11Property ()
eventLoop dispatch = do
(X11Context d w) <- ask
liftIO $ do
xSetErrorHandler
selectInput d w $ propertyChangeMask .|. substructureNotifyMask
allocaXEvent $ \e -> forever $ do
event <- nextEvent d e >> getEvent e
case event of
MapNotifyEvent _ _ _ _ _ window _ -> do
selectInput d window propertyChangeMask
_ -> return ()
dispatch event
sendCommandEvent :: Atom -> Atom -> X11Property ()
sendCommandEvent cmd arg = do
(X11Context dpy root) <- ask
sendCustomEvent dpy cmd arg root root
sendWindowEvent :: Atom -> X11Window -> X11Property ()
sendWindowEvent cmd win = do
(X11Context dpy root) <- ask
sendCustomEvent dpy cmd cmd root win
getDefaultCtx :: IO X11Context
getDefaultCtx = do
d <- openDisplay ""
w <- rootWindow d $ defaultScreen d
return $ X11Context d w
fetch :: (Integral a)
=> PropertyFetcher a
-> Maybe X11Window
-> String
-> X11Property (Maybe [a])
fetch fetcher window name = do
(X11Context dpy root) <- ask
atom <- getAtom name
prop <- liftIO $ fetcher dpy atom (fromMaybe root window)
return prop
fetchWindowHints :: X11Window -> X11Property WMHints
fetchWindowHints window = do
(X11Context d _) <- ask
hints <- liftIO $ getWMHints d window
return hints
sendCustomEvent :: Display
-> Atom
-> Atom
-> X11Window
-> X11Window
-> X11Property ()
sendCustomEvent dpy cmd arg root win = do
liftIO $ allocaXEvent $ \e -> do
setEventType e clientMessage
setClientMessageEvent e win cmd 32 arg currentTime
sendEvent dpy root False structureNotifyMask e
sync dpy False