{-# LANGUAGE OverloadedStrings #-}
module WildBind.X11.Internal.Window
(
Window,
ActiveWindow,
emptyWindow,
fromWinID,
winInstance,
winClass,
winName,
winID,
getActiveWindow,
defaultRootWindowForDisplay
) where
import Control.Applicative ((<$>),(<|>),empty)
import Control.Monad (guard)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.Maybe (MaybeT(MaybeT),runMaybeT)
import Data.Maybe (listToMaybe)
import Data.Text (Text)
import qualified Data.Text as Text
import qualified Foreign
import qualified Graphics.X11.Xlib as Xlib
import qualified Graphics.X11.Xlib.Extras as XlibE
data Window =
Window
{ winInstance :: Text,
winClass :: Text,
winName :: Text,
winID :: Xlib.Window
} deriving (Eq,Ord,Show)
type ActiveWindow = Window
emptyWindow :: Window
emptyWindow = Window "" "" "" 0
fromWinID :: Xlib.Window -> Window
fromWinID wid = emptyWindow { winID = wid }
getActiveWindow :: Xlib.Display -> IO ActiveWindow
getActiveWindow disp = maybe emptyWindow id <$> runMaybeT getActiveWindowM where
getActiveWindowM = do
awin <- xGetActiveWindow disp
guard (awin /= 0)
name <- xGetWindowName disp awin
class_hint <- liftIO $ xGetClassHint disp awin
return $ (uncurry Window) class_hint name awin
defaultRootWindowForDisplay :: Xlib.Display -> Window
defaultRootWindowForDisplay disp = Window "" "" "" $ Xlib.defaultRootWindow disp
ewmhIsSupported :: Xlib.Display -> String -> IO Bool
ewmhIsSupported disp feature_str = do
req <- Xlib.internAtom disp "_NET_SUPPORTED" False
feature <- Xlib.internAtom disp feature_str False
result <- XlibE.getWindowProperty32 disp req (Xlib.defaultRootWindow disp)
case result of
Nothing -> return False
Just atoms -> return $ any ((feature ==) . fromIntegral) atoms
xGetActiveWindow :: Xlib.Display -> MaybeT IO Xlib.Window
xGetActiveWindow disp = do
let req_str = "_NET_ACTIVE_WINDOW"
supported <- liftIO $ ewmhIsSupported disp req_str
if not supported
then empty
else do
req <- liftIO $ Xlib.internAtom disp req_str False
result <- MaybeT $ XlibE.getWindowProperty32 disp req (Xlib.defaultRootWindow disp)
case result of
[] -> empty
(val:_) -> return $ fromIntegral val
xGetClassHint :: Xlib.Display -> Xlib.Window -> IO (Text, Text)
xGetClassHint disp win = do
hint <- XlibE.getClassHint disp win
return (Text.pack $ XlibE.resName hint, Text.pack $ XlibE.resClass hint)
xGetTextProperty :: Xlib.Display -> Xlib.Window -> String -> MaybeT IO Text
xGetTextProperty disp win prop_name = do
req <- liftIO $ Xlib.internAtom disp prop_name False
text_prop <- MaybeT $ Foreign.alloca $ \ptr_prop -> do
status <- XlibE.xGetTextProperty disp win ptr_prop req
if status == 0
then return Nothing
else fmap Just $ Foreign.peek ptr_prop
Text.pack <$> MaybeT (listToMaybe <$> (XlibE.wcTextPropertyToTextList disp text_prop))
xGetWindowName :: Xlib.Display -> Xlib.Window -> MaybeT IO Text
xGetWindowName disp win = xGetTextProperty disp win "_NET_WM_NAME" <|> xGetTextProperty disp win "WM_NAME"