module WildBind.X11.Internal.FrontEnd
(
X11Front(..),
withFrontEnd,
withX11Front,
makeFrontEnd,
defaultRootWindow
) 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 (when, filterM, mapM_)
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.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
( xKeyEventToXKeyInput,
xGrabKey, xUngrabKey,
XKeyInput(..), KeyMaskMap, getKeyMaskMap,
KeyEventType(..)
)
import WildBind.X11.Internal.Window
( ActiveWindow,getActiveWindow, Window,
winInstance, winClass, winName, emptyWindow,
defaultRootWindowForDisplay
)
import qualified WildBind.X11.Internal.NotificationDebouncer as Ndeb
import qualified WildBind.X11.Internal.GrabMan as GM
data X11Front k =
X11Front { x11Display :: Xlib.Display,
x11Debouncer :: Ndeb.Debouncer,
x11PrevActiveWindow :: IORef (Maybe ActiveWindow),
x11PendingEvents :: TChan (FrontEvent ActiveWindow k),
x11KeyMaskMap :: KeyMaskMap,
x11GrabMan :: IORef (GM.GrabMan k)
}
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 :: (XKeyInput i, WBD.Describable i, Ord i) => (FrontEnd ActiveWindow i -> IO a) -> IO a
withFrontEnd action = withX11Front' "WildBind.X11.withFrontEnd" $ \x11front -> action (makeFrontEnd x11front)
withX11Front :: (X11Front k -> IO a) -> IO a
withX11Front = withX11Front' "WildBind.X11.withX11Front"
withX11Front' :: String
-> (X11Front k -> IO a)
-> IO a
withX11Front' func_name = if rtsSupportsBoundThreads then impl else error_impl where
impl = runContT $ do
disp <- ContT $ bracket openMyDisplay Xlib.closeDisplay
keymask_map <- liftIO $ getKeyMaskMap disp
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
grab_man <- liftIO $ GM.new keymask_map disp (Xlib.defaultRootWindow disp)
liftIO $ Ndeb.notify debouncer
return $ X11Front disp debouncer awin_ref pending_events keymask_map grab_man
error_impl _ = throwIO $ userError ("You need to build with -threaded option when you use " ++ func_name ++ " function.")
tellElem :: Monad m => a -> WriterT [a] m ()
tellElem a = tell [a]
data InternalEvent = IEKey KeyEventType
| IEDebounced
| IEActiveWindow
| IEUnknown
identifyEvent :: Ndeb.Debouncer -> Xlib.XEventPtr -> IO InternalEvent
identifyEvent deb xev = do
xtype <- Xlib.get_EventType xev
identify xtype
where
identify xtype | xtype == Xlib.keyPress = return $ IEKey KeyPress
| xtype == Xlib.keyRelease = return $ IEKey KeyRelease
| xtype == Xlib.configureNotify || xtype == Xlib.destroyNotify = return $ IEActiveWindow
| otherwise = do
is_deb_event <- Ndeb.isDebouncedEvent deb xev
if is_deb_event
then return IEDebounced
else return IEUnknown
convertEvent :: (XKeyInput k) => KeyMaskMap -> Xlib.Display -> Ndeb.Debouncer -> Xlib.XEventPtr -> IO [FrontEvent ActiveWindow k]
convertEvent kmmap disp deb xev = execWriterT $ convertEventWriter where
tellChangeEvent = (tellElem . FEChange) =<< (liftIO $ getActiveWindow disp)
convertEventWriter :: XKeyInput k => WriterT [FrontEvent ActiveWindow k] IO ()
convertEventWriter = do
in_event <- liftIO $ identifyEvent deb xev
case in_event of
IEKey ev_type -> do
let key_ev = Xlib.asKeyEvent xev
tellChangeEvent
(maybe (return ()) tellElem) =<< (liftIO $ runMaybeT (FEInput <$> xKeyEventToXKeyInput kmmap ev_type key_ev))
IEDebounced -> tellChangeEvent
IEActiveWindow -> liftIO (Ndeb.notify deb) >> return ()
IEUnknown -> return ()
isSignificantEvent :: X11Front k -> FrontEvent ActiveWindow k -> IO Bool
isSignificantEvent front (FEChange new_state) = do
m_old_state <- liftIO $ readIORef $ x11PrevActiveWindow front
case m_old_state of
Nothing -> return True
Just old_state -> return (not $ new_state == old_state)
isSignificantEvent _ _ = return True
updateState :: X11Front k -> FrontEvent ActiveWindow k -> IO ()
updateState front fev = case fev of
(FEInput _) -> return ()
(FEChange s) -> writeIORef (x11PrevActiveWindow front) (Just s)
nextEvent :: (XKeyInput 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 = do
fevents <- filterM (isSignificantEvent handle)
=<< convertEvent (x11KeyMaskMap handle) (x11Display handle) (x11Debouncer handle) xev
mapM_ (updateState handle) fevents
return fevents
makeFrontEnd :: (XKeyInput k, WBD.Describable k, Ord k) => X11Front k -> FrontEnd ActiveWindow k
makeFrontEnd f = FrontEnd { frontDefaultDescription = WBD.describe,
frontSetGrab = runGrab GM.DoSetGrab,
frontUnsetGrab = runGrab GM.DoUnsetGrab,
frontNextEvent = nextEvent f
}
where
runGrab = GM.modify (x11GrabMan f)
defaultRootWindow :: X11Front k -> Window
defaultRootWindow = defaultRootWindowForDisplay . x11Display