module WildBind.X11.Internal.FrontEnd
(
X11Front (..)
, withFrontEnd
, withX11Front
, makeFrontEnd
, defaultRootWindow
) where
import Control.Applicative (empty, (<$>))
import Control.Concurrent (rtsSupportsBoundThreads)
import Control.Concurrent.STM (TChan, atomically, newTChanIO,
tryReadTChan, writeTChan)
import Control.Exception (bracket, throwIO)
import Control.Monad (filterM, mapM_, when)
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, frontNextEvent, frontSetGrab, frontUnsetGrab),
FrontEvent (FEChange, FEInput))
import qualified WildBind.Description as WBD
import qualified WildBind.X11.Internal.GrabMan as GM
import WildBind.X11.Internal.Key (KeyEventType (..), KeyMaskMap,
XKeyInput (..), getKeyMaskMap,
xGrabKey, xKeyEventToXKeyInput,
xUngrabKey)
import qualified WildBind.X11.Internal.NotificationDebouncer as Ndeb
import WildBind.X11.Internal.Window (ActiveWindow, Window,
defaultRootWindowForDisplay,
emptyWindow, getActiveWindow,
winClass, winInstance, winName)
data X11Front k
= X11Front
{ forall k. X11Front k -> Display
x11Display :: Xlib.Display
, forall k. X11Front k -> Debouncer
x11Debouncer :: Ndeb.Debouncer
, forall k. X11Front k -> IORef (Maybe ActiveWindow)
x11PrevActiveWindow :: IORef (Maybe ActiveWindow)
, forall k. X11Front k -> TChan (FrontEvent ActiveWindow k)
x11PendingEvents :: TChan (FrontEvent ActiveWindow k)
, forall k. X11Front k -> KeyMaskMap
x11KeyMaskMap :: KeyMaskMap
, forall k. X11Front k -> IORef (GrabMan k)
x11GrabMan :: IORef (GM.GrabMan k)
}
x11PopPendingEvent :: X11Front k -> IO (Maybe (FrontEvent ActiveWindow k))
x11PopPendingEvent :: forall k. X11Front k -> IO (Maybe (FrontEvent ActiveWindow k))
x11PopPendingEvent X11Front k
f = forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TChan a -> STM (Maybe a)
tryReadTChan forall a b. (a -> b) -> a -> b
$ forall k. X11Front k -> TChan (FrontEvent ActiveWindow k)
x11PendingEvents X11Front k
f
x11UnshiftPendingEvents :: X11Front k -> [FrontEvent ActiveWindow k] -> IO ()
x11UnshiftPendingEvents :: forall k. X11Front k -> [FrontEvent ActiveWindow k] -> IO ()
x11UnshiftPendingEvents X11Front k
f = forall a. STM a -> IO a
atomically forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall a. TChan a -> a -> STM ()
writeTChan forall a b. (a -> b) -> a -> b
$ forall k. X11Front k -> TChan (FrontEvent ActiveWindow k)
x11PendingEvents X11Front k
f)
openMyDisplay :: IO Xlib.Display
openMyDisplay :: IO Display
openMyDisplay = String -> IO Display
Xlib.openDisplay String
""
withFrontEnd :: (XKeyInput i, WBD.Describable i, Ord i) => (FrontEnd ActiveWindow i -> IO a) -> IO a
withFrontEnd :: forall i a.
(XKeyInput i, Describable i, Ord i) =>
(FrontEnd ActiveWindow i -> IO a) -> IO a
withFrontEnd FrontEnd ActiveWindow i -> IO a
action = forall k a. String -> (X11Front k -> IO a) -> IO a
withX11Front' String
"WildBind.X11.withFrontEnd" forall a b. (a -> b) -> a -> b
$ \X11Front i
x11front -> FrontEnd ActiveWindow i -> IO a
action (forall k.
(XKeyInput k, Describable k, Ord k) =>
X11Front k -> FrontEnd ActiveWindow k
makeFrontEnd X11Front i
x11front)
withX11Front :: (X11Front k -> IO a) -> IO a
withX11Front :: forall k a. (X11Front k -> IO a) -> IO a
withX11Front = forall k a. String -> (X11Front k -> IO a) -> IO a
withX11Front' String
"WildBind.X11.withX11Front"
withX11Front' :: String
-> (X11Front k -> IO a)
-> IO a
withX11Front' :: forall k a. String -> (X11Front k -> IO a) -> IO a
withX11Front' String
func_name = if Bool
rtsSupportsBoundThreads then forall k a. (X11Front k -> IO a) -> IO a
impl else forall {p} {a}. p -> IO a
error_impl where
impl :: (X11Front k -> IO r) -> IO r
impl = forall {k} (r :: k) (m :: k -> *) a.
ContT r m a -> (a -> m r) -> m r
runContT forall a b. (a -> b) -> a -> b
$ do
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ IO ()
doInitThreads
Display
disp <- forall {k} (r :: k) (m :: k -> *) a.
((a -> m r) -> m r) -> ContT r m a
ContT forall a b. (a -> b) -> a -> b
$ forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket IO Display
openMyDisplay Display -> IO ()
Xlib.closeDisplay
KeyMaskMap
keymask_map <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Display -> IO KeyMaskMap
getKeyMaskMap Display
disp
Display
notif_disp <- forall {k} (r :: k) (m :: k -> *) a.
((a -> m r) -> m r) -> ContT r m a
ContT forall a b. (a -> b) -> a -> b
$ forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket IO Display
openMyDisplay Display -> IO ()
Xlib.closeDisplay
Debouncer
debouncer <- forall {k} (r :: k) (m :: k -> *) a.
((a -> m r) -> m r) -> ContT r m a
ContT forall a b. (a -> b) -> a -> b
$ forall a. Display -> (Debouncer -> IO a) -> IO a
Ndeb.withDebouncer Display
notif_disp
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Display -> EventMask -> EventMask -> IO ()
Xlib.selectInput Display
disp (Display -> EventMask
Xlib.defaultRootWindow Display
disp)
(EventMask
Xlib.substructureNotifyMask forall a. Bits a => a -> a -> a
.|. EventMask
Ndeb.xEventMask)
IORef (Maybe ActiveWindow)
awin_ref <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (IORef a)
newIORef forall a. Maybe a
Nothing
TChan (FrontEvent ActiveWindow k)
pending_events <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. IO (TChan a)
newTChanIO
IORef (GrabMan k)
grab_man <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall k.
KeyMaskMap -> Display -> EventMask -> IO (IORef (GrabMan k))
GM.new KeyMaskMap
keymask_map Display
disp (Display -> EventMask
Xlib.defaultRootWindow Display
disp)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Debouncer -> IO ()
Ndeb.notify Debouncer
debouncer
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall k.
Display
-> Debouncer
-> IORef (Maybe ActiveWindow)
-> TChan (FrontEvent ActiveWindow k)
-> KeyMaskMap
-> IORef (GrabMan k)
-> X11Front k
X11Front Display
disp Debouncer
debouncer IORef (Maybe ActiveWindow)
awin_ref TChan (FrontEvent ActiveWindow k)
pending_events KeyMaskMap
keymask_map IORef (GrabMan k)
grab_man
error_impl :: p -> IO a
error_impl p
_ = forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$ String -> IOError
userError (String
"You need to build with -threaded option when you use " forall a. [a] -> [a] -> [a]
++ String
func_name forall a. [a] -> [a] -> [a]
++ String
" function.")
doInitThreads :: IO ()
doInitThreads = do
Status
ret <- IO Status
Xlib.initThreads
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Status
ret forall a. Eq a => a -> a -> Bool
== Status
0) forall a b. (a -> b) -> a -> b
$ do
forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$ String -> IOError
userError (String
"Failure in XInitThreads.")
tellElem :: Monad m => a -> WriterT [a] m ()
tellElem :: forall (m :: * -> *) a. Monad m => a -> WriterT [a] m ()
tellElem a
a = forall (m :: * -> *) w. Monad m => w -> WriterT w m ()
tell [a
a]
data InternalEvent
= IEKey KeyEventType
| IEDebounced
| IEActiveWindow
| IEUnknown
identifyEvent :: Ndeb.Debouncer -> Xlib.XEventPtr -> IO InternalEvent
identifyEvent :: Debouncer -> XEventPtr -> IO InternalEvent
identifyEvent Debouncer
deb XEventPtr
xev = do
EventType
xtype <- XEventPtr -> IO EventType
Xlib.get_EventType XEventPtr
xev
EventType -> IO InternalEvent
identify EventType
xtype
where
identify :: EventType -> IO InternalEvent
identify EventType
xtype | EventType
xtype forall a. Eq a => a -> a -> Bool
== EventType
Xlib.keyPress = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ KeyEventType -> InternalEvent
IEKey KeyEventType
KeyPress
| EventType
xtype forall a. Eq a => a -> a -> Bool
== EventType
Xlib.keyRelease = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ KeyEventType -> InternalEvent
IEKey KeyEventType
KeyRelease
| EventType
xtype forall a. Eq a => a -> a -> Bool
== EventType
Xlib.configureNotify Bool -> Bool -> Bool
|| EventType
xtype forall a. Eq a => a -> a -> Bool
== EventType
Xlib.destroyNotify = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ InternalEvent
IEActiveWindow
| Bool
otherwise = do
Bool
is_deb_event <- Debouncer -> XEventPtr -> IO Bool
Ndeb.isDebouncedEvent Debouncer
deb XEventPtr
xev
if Bool
is_deb_event
then forall (m :: * -> *) a. Monad m => a -> m a
return InternalEvent
IEDebounced
else forall (m :: * -> *) a. Monad m => a -> m a
return InternalEvent
IEUnknown
convertEvent :: (XKeyInput k) => KeyMaskMap -> Xlib.Display -> Ndeb.Debouncer -> Xlib.XEventPtr -> IO [FrontEvent ActiveWindow k]
convertEvent :: forall k.
XKeyInput k =>
KeyMaskMap
-> Display
-> Debouncer
-> XEventPtr
-> IO [FrontEvent ActiveWindow k]
convertEvent KeyMaskMap
kmmap Display
disp Debouncer
deb XEventPtr
xev = forall (m :: * -> *) w a. Monad m => WriterT w m a -> m w
execWriterT forall a b. (a -> b) -> a -> b
$ forall k. XKeyInput k => WriterT [FrontEvent ActiveWindow k] IO ()
convertEventWriter where
tellChangeEvent :: WriterT [FrontEvent ActiveWindow i] IO ()
tellChangeEvent = (forall (m :: * -> *) a. Monad m => a -> WriterT [a] m ()
tellElem forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s i. s -> FrontEvent s i
FEChange) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Display -> IO ActiveWindow
getActiveWindow Display
disp)
convertEventWriter :: XKeyInput k => WriterT [FrontEvent ActiveWindow k] IO ()
convertEventWriter :: forall k. XKeyInput k => WriterT [FrontEvent ActiveWindow k] IO ()
convertEventWriter = do
InternalEvent
in_event <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Debouncer -> XEventPtr -> IO InternalEvent
identifyEvent Debouncer
deb XEventPtr
xev
case InternalEvent
in_event of
IEKey KeyEventType
ev_type -> do
let key_ev :: XKeyEventPtr
key_ev = XEventPtr -> XKeyEventPtr
Xlib.asKeyEvent XEventPtr
xev
forall {i}. WriterT [FrontEvent ActiveWindow i] IO ()
tellChangeEvent
(forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return ()) forall (m :: * -> *) a. Monad m => a -> WriterT [a] m ()
tellElem) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (forall s i. i -> FrontEvent s i
FEInput forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k.
XKeyInput k =>
KeyMaskMap -> KeyEventType -> XKeyEventPtr -> MaybeT IO k
xKeyEventToXKeyInput KeyMaskMap
kmmap KeyEventType
ev_type XKeyEventPtr
key_ev))
InternalEvent
IEDebounced -> forall {i}. WriterT [FrontEvent ActiveWindow i] IO ()
tellChangeEvent
InternalEvent
IEActiveWindow -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Debouncer -> IO ()
Ndeb.notify Debouncer
deb) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return ()
InternalEvent
IEUnknown -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
isSignificantEvent :: X11Front k -> FrontEvent ActiveWindow k -> IO Bool
isSignificantEvent :: forall k. X11Front k -> FrontEvent ActiveWindow k -> IO Bool
isSignificantEvent X11Front k
front (FEChange ActiveWindow
new_state) = do
Maybe ActiveWindow
m_old_state <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> IO a
readIORef forall a b. (a -> b) -> a -> b
$ forall k. X11Front k -> IORef (Maybe ActiveWindow)
x11PrevActiveWindow X11Front k
front
case Maybe ActiveWindow
m_old_state of
Maybe ActiveWindow
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
Just ActiveWindow
old_state -> forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ ActiveWindow
new_state forall a. Eq a => a -> a -> Bool
== ActiveWindow
old_state)
isSignificantEvent X11Front k
_ FrontEvent ActiveWindow k
_ = forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
updateState :: X11Front k -> FrontEvent ActiveWindow k -> IO ()
updateState :: forall k. X11Front k -> FrontEvent ActiveWindow k -> IO ()
updateState X11Front k
front FrontEvent ActiveWindow k
fev = case FrontEvent ActiveWindow k
fev of
(FEInput k
_) -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
(FEChange ActiveWindow
s) -> forall a. IORef a -> a -> IO ()
writeIORef (forall k. X11Front k -> IORef (Maybe ActiveWindow)
x11PrevActiveWindow X11Front k
front) (forall a. a -> Maybe a
Just ActiveWindow
s)
nextEvent :: (XKeyInput k) => X11Front k -> IO (FrontEvent ActiveWindow k)
nextEvent :: forall k.
XKeyInput k =>
X11Front k -> IO (FrontEvent ActiveWindow k)
nextEvent X11Front k
handle = IO (FrontEvent ActiveWindow k)
loop where
loop :: IO (FrontEvent ActiveWindow k)
loop = do
Maybe (FrontEvent ActiveWindow k)
mpending <- forall k. X11Front k -> IO (Maybe (FrontEvent ActiveWindow k))
x11PopPendingEvent X11Front k
handle
case Maybe (FrontEvent ActiveWindow k)
mpending of
Just FrontEvent ActiveWindow k
eve -> forall (m :: * -> *) a. Monad m => a -> m a
return FrontEvent ActiveWindow k
eve
Maybe (FrontEvent ActiveWindow k)
Nothing -> IO (FrontEvent ActiveWindow k)
nextEventFromX11
nextEventFromX11 :: IO (FrontEvent ActiveWindow k)
nextEventFromX11 = forall a. (XEventPtr -> IO a) -> IO a
Xlib.allocaXEvent forall a b. (a -> b) -> a -> b
$ \XEventPtr
xev -> do
Display -> XEventPtr -> IO ()
Xlib.nextEvent (forall k. X11Front k -> Display
x11Display X11Front k
handle) XEventPtr
xev
[FrontEvent ActiveWindow k]
got_events <- XEventPtr -> IO [FrontEvent ActiveWindow k]
processEvents XEventPtr
xev
case [FrontEvent ActiveWindow k]
got_events of
[] -> IO (FrontEvent ActiveWindow k)
loop
(FrontEvent ActiveWindow k
eve : [FrontEvent ActiveWindow k]
rest) -> do
forall k. X11Front k -> [FrontEvent ActiveWindow k] -> IO ()
x11UnshiftPendingEvents X11Front k
handle [FrontEvent ActiveWindow k]
rest
forall (m :: * -> *) a. Monad m => a -> m a
return FrontEvent ActiveWindow k
eve
processEvents :: XEventPtr -> IO [FrontEvent ActiveWindow k]
processEvents XEventPtr
xev = do
[FrontEvent ActiveWindow k]
fevents <- forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM (forall k. X11Front k -> FrontEvent ActiveWindow k -> IO Bool
isSignificantEvent X11Front k
handle)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall k.
XKeyInput k =>
KeyMaskMap
-> Display
-> Debouncer
-> XEventPtr
-> IO [FrontEvent ActiveWindow k]
convertEvent (forall k. X11Front k -> KeyMaskMap
x11KeyMaskMap X11Front k
handle) (forall k. X11Front k -> Display
x11Display X11Front k
handle) (forall k. X11Front k -> Debouncer
x11Debouncer X11Front k
handle) XEventPtr
xev
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall k. X11Front k -> FrontEvent ActiveWindow k -> IO ()
updateState X11Front k
handle) [FrontEvent ActiveWindow k]
fevents
forall (m :: * -> *) a. Monad m => a -> m a
return [FrontEvent ActiveWindow k]
fevents
makeFrontEnd :: (XKeyInput k, WBD.Describable k, Ord k) => X11Front k -> FrontEnd ActiveWindow k
makeFrontEnd :: forall k.
(XKeyInput k, Describable k, Ord k) =>
X11Front k -> FrontEnd ActiveWindow k
makeFrontEnd X11Front k
f = FrontEnd { frontDefaultDescription :: k -> ActionDescription
frontDefaultDescription = forall d. Describable d => d -> ActionDescription
WBD.describe,
frontSetGrab :: k -> IO ()
frontSetGrab = GrabOp -> k -> IO ()
runGrab GrabOp
GM.DoSetGrab,
frontUnsetGrab :: k -> IO ()
frontUnsetGrab = GrabOp -> k -> IO ()
runGrab GrabOp
GM.DoUnsetGrab,
frontNextEvent :: IO (FrontEvent ActiveWindow k)
frontNextEvent = forall k.
XKeyInput k =>
X11Front k -> IO (FrontEvent ActiveWindow k)
nextEvent X11Front k
f
}
where
runGrab :: GrabOp -> k -> IO ()
runGrab = forall k.
(XKeyInput k, Ord k) =>
IORef (GrabMan k) -> GrabOp -> k -> IO ()
GM.modify (forall k. X11Front k -> IORef (GrabMan k)
x11GrabMan X11Front k
f)
defaultRootWindow :: X11Front k -> Window
defaultRootWindow :: forall k. X11Front k -> ActiveWindow
defaultRootWindow = Display -> ActiveWindow
defaultRootWindowForDisplay forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k. X11Front k -> Display
x11Display