module WildBind.X11
(
withFrontEnd,
Window,
ActiveWindow,
winInstance,
winClass,
winName
) where
import Control.Applicative ((<$>), empty)
import Control.Concurrent (rtsSupportsBoundThreads)
import Control.Concurrent.STM (atomically, TChan, newTChanIO, tryReadTChan, writeTChan)
import Control.Exception (bracket, throwIO)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.Cont (ContT(ContT), runContT)
import Control.Monad.Trans.Maybe (MaybeT, runMaybeT)
import Control.Monad.Trans.List (ListT(ListT), runListT)
import Control.Monad.Trans.Writer (WriterT, execWriterT, tell)
import Data.Bits ((.|.))
import Data.IORef (IORef, newIORef, readIORef, writeIORef)
import qualified Graphics.X11.Xlib as Xlib
import WildBind
( FrontEnd(FrontEnd, frontDefaultDescription, frontSetGrab, frontUnsetGrab, frontNextEvent),
FrontEvent(FEInput,FEChange)
)
import qualified WildBind.Description as WBD
import WildBind.X11.Internal.Key (KeySymLike, ModifierLike, xEventToKeySymLike, xGrabKey, xUngrabKey)
import WildBind.X11.Internal.Window (ActiveWindow,getActiveWindow, Window, winInstance, winClass, winName, emptyWindow)
import qualified WildBind.X11.Internal.NotificationDebouncer as Ndeb
data X11Front k =
X11Front { x11Display :: Xlib.Display,
x11Debouncer :: Ndeb.Debouncer,
x11PrevActiveWindow :: IORef (Maybe ActiveWindow),
x11PendingEvents :: TChan (FrontEvent ActiveWindow k)
}
x11RootWindow :: X11Front k -> Xlib.Window
x11RootWindow = Xlib.defaultRootWindow . x11Display
x11PopPendingEvent :: X11Front k -> IO (Maybe (FrontEvent ActiveWindow k))
x11PopPendingEvent f = atomically $ tryReadTChan $ x11PendingEvents f
x11UnshiftPendingEvents :: X11Front k -> [FrontEvent ActiveWindow k] -> IO ()
x11UnshiftPendingEvents f = atomically . mapM_ (writeTChan $ x11PendingEvents f)
openMyDisplay :: IO Xlib.Display
openMyDisplay = Xlib.openDisplay ""
withFrontEnd :: (KeySymLike i, ModifierLike i, WBD.Describable i) => (FrontEnd ActiveWindow i -> IO a) -> IO a
withFrontEnd = if rtsSupportsBoundThreads then impl else error_impl where
impl = runContT $ do
disp <- ContT $ bracket openMyDisplay Xlib.closeDisplay
notif_disp <- ContT $ bracket openMyDisplay Xlib.closeDisplay
debouncer <- ContT $ Ndeb.withDebouncer notif_disp
liftIO $ Xlib.selectInput disp (Xlib.defaultRootWindow disp)
(Xlib.substructureNotifyMask .|. Ndeb.xEventMask)
awin_ref <- liftIO $ newIORef Nothing
pending_events <- liftIO $ newTChanIO
liftIO $ Ndeb.notify debouncer
return $ makeFrontEnd $ X11Front disp debouncer awin_ref pending_events
error_impl _ = throwIO $ userError "You need to build with -threaded option when you use WildBind.X11.withFrontEnd function."
tellElem :: Monad m => a -> WriterT [a] m ()
tellElem a = tell [a]
convertEvent :: (KeySymLike k) => Xlib.Display -> Ndeb.Debouncer -> Xlib.XEventPtr -> ListT IO (FrontEvent ActiveWindow k)
convertEvent disp deb xev = ListT $ execWriterT $ convertEventWriter where
convertEventWriter :: KeySymLike k => WriterT [FrontEvent ActiveWindow k] IO ()
convertEventWriter = do
xtype <- liftIO $ Xlib.get_EventType xev
let is_key_event = xtype == Xlib.keyRelease
is_awin_event = xtype == Xlib.configureNotify || xtype == Xlib.destroyNotify
tellChangeEvent = (tellElem . FEChange) =<< (liftIO $ getActiveWindow disp)
is_deb_event <- liftIO $ Ndeb.isDebouncedEvent deb xev
if is_key_event
then do
tellChangeEvent
(maybe (return ()) tellElem) =<< (liftIO $ runMaybeT (FEInput <$> xEventToKeySymLike xev))
else if is_deb_event
then tellChangeEvent
else if is_awin_event
then liftIO (Ndeb.notify deb) >> return ()
else return ()
filterUnchangedEvent :: X11Front k -> FrontEvent ActiveWindow k -> ListT IO ()
filterUnchangedEvent front (FEChange new_state) = do
m_old_state <- liftIO $ readIORef $ x11PrevActiveWindow front
case m_old_state of
Nothing -> return ()
Just old_state -> if new_state == old_state then empty else return ()
filterUnchangedEvent _ _ = return ()
updateState :: X11Front k -> FrontEvent ActiveWindow k -> IO ()
updateState front fev = case fev of
(FEInput _) -> return ()
(FEChange s) -> writeIORef (x11PrevActiveWindow front) (Just s)
grabDef :: (KeySymLike k, ModifierLike k) => (Xlib.Display -> Xlib.Window -> k -> IO ()) -> X11Front k -> k -> IO ()
grabDef func front key = func (x11Display front) (x11RootWindow front) key
nextEvent :: (KeySymLike k) => X11Front k -> IO (FrontEvent ActiveWindow k)
nextEvent handle = loop where
loop = do
mpending <- x11PopPendingEvent handle
case mpending of
Just eve -> return eve
Nothing -> nextEventFromX11
nextEventFromX11 = Xlib.allocaXEvent $ \xev -> do
Xlib.nextEvent (x11Display handle) xev
got_events <- processEvents xev
case got_events of
[] -> loop
(eve : rest) -> do
x11UnshiftPendingEvents handle rest
return eve
processEvents xev = runListT $ do
fevent <- convertEvent (x11Display handle) (x11Debouncer handle) xev
filterUnchangedEvent handle fevent
liftIO $ updateState handle fevent
return fevent
makeFrontEnd :: (KeySymLike k, ModifierLike k, WBD.Describable k) => X11Front k -> FrontEnd ActiveWindow k
makeFrontEnd f = FrontEnd { frontDefaultDescription = WBD.describe,
frontSetGrab = grabDef xGrabKey f,
frontUnsetGrab = grabDef xUngrabKey f,
frontNextEvent = nextEvent f
}