-- |
-- Module: WildBind.X11.Internal.FrontEnd
-- Description: WildBind FrontEnd implementation for X11
-- Maintainer: Toshio Ito <debug.ito@gmail.com>
--
-- __This is an internal module. Package users should not rely on this.__
module WildBind.X11.Internal.FrontEnd
    ( -- * X11Front
      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)

-- | The X11 front-end. @k@ is the input key type.
--
-- This is the implementation of the 'FrontEnd' given by
-- 'withFrontEnd' function. With this object, you can do more advanced
-- actions. See "WildBind.X11.Emulate".
--
-- 'X11Front' is relatively low-level interface, so it's more likely
-- for this API to change in the future than 'FrontEnd'.
--
-- @since 0.2.0.0
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 = STM (Maybe (FrontEvent ActiveWindow k))
-> IO (Maybe (FrontEvent ActiveWindow k))
forall a. STM a -> IO a
atomically (STM (Maybe (FrontEvent ActiveWindow k))
 -> IO (Maybe (FrontEvent ActiveWindow k)))
-> STM (Maybe (FrontEvent ActiveWindow k))
-> IO (Maybe (FrontEvent ActiveWindow k))
forall a b. (a -> b) -> a -> b
$ TChan (FrontEvent ActiveWindow k)
-> STM (Maybe (FrontEvent ActiveWindow k))
forall a. TChan a -> STM (Maybe a)
tryReadTChan (TChan (FrontEvent ActiveWindow k)
 -> STM (Maybe (FrontEvent ActiveWindow k)))
-> TChan (FrontEvent ActiveWindow k)
-> STM (Maybe (FrontEvent ActiveWindow k))
forall a b. (a -> b) -> a -> b
$ X11Front k -> TChan (FrontEvent ActiveWindow k)
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 = STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ())
-> ([FrontEvent ActiveWindow k] -> STM ())
-> [FrontEvent ActiveWindow k]
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FrontEvent ActiveWindow k -> STM ())
-> [FrontEvent ActiveWindow k] -> STM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (TChan (FrontEvent ActiveWindow k)
-> FrontEvent ActiveWindow k -> STM ()
forall a. TChan a -> a -> STM ()
writeTChan (TChan (FrontEvent ActiveWindow k)
 -> FrontEvent ActiveWindow k -> STM ())
-> TChan (FrontEvent ActiveWindow k)
-> FrontEvent ActiveWindow k
-> STM ()
forall a b. (a -> b) -> a -> b
$ X11Front k -> TChan (FrontEvent ActiveWindow k)
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
""

-- | Initialize and obtain 'FrontEnd' for X11, and run the given
-- action.
--
-- The X11 'FrontEnd' watches and provides 'ActiveWindow' as the
-- front-end state. 'ActiveWindow' keeps information about the window
-- currently active. As for the input type @i@, this 'FrontEnd' gets
-- keyboard events from the X server.
--
-- CAVEATS
--
-- Code using this function must be compiled
-- __with @-threaded@ option enabled__ in @ghc@. Otherwise, it aborts.
--
-- Basically you should call this function directly under @main@. This
-- is because this function calls some low-level X11 functions to
-- initialize the X11 client, which should be done first.
--
-- Because this 'FrontEnd' currently uses @XGrabKey(3)@ to get the
-- input, it may cause some weird behavior such as:
--
-- - Every input event makes the active window lose focus
--   temporarily. This may result in flickering cursor, for example. See
--   also: https://stackoverflow.com/questions/15270420/
--
-- - Key input is captured only while the first grabbed key is
--   pressed. For example, if @(release xK_a)@ and @(release xK_b)@
--   are bound, and you input @(press xK_a)@, @(press xK_b)@, @(release xK_a)@,
--   @(release xK_b)@, the last @(release xK_b)@ is NOT captured
--   because key grab ends with @(release xK_a)@.
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 = String -> (X11Front i -> IO a) -> IO a
forall k a. String -> (X11Front k -> IO a) -> IO a
withX11Front' String
"WildBind.X11.withFrontEnd" ((X11Front i -> IO a) -> IO a) -> (X11Front i -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \X11Front i
x11front -> FrontEnd ActiveWindow i -> IO a
action (X11Front i -> FrontEnd ActiveWindow i
forall k.
(XKeyInput k, Describable k, Ord k) =>
X11Front k -> FrontEnd ActiveWindow k
makeFrontEnd X11Front i
x11front)

-- | Same as 'withFrontEnd', but it creates 'X11Front'. To create
-- 'FrontEnd', use 'makeFrontEnd'.
--
-- @since 0.2.0.0
withX11Front :: (X11Front k -> IO a) -> IO a
withX11Front :: forall k a. (X11Front k -> IO a) -> IO a
withX11Front = String -> (X11Front k -> IO a) -> IO a
forall k a. String -> (X11Front k -> IO a) -> IO a
withX11Front' String
"WildBind.X11.withX11Front"

withX11Front' :: String -- ^ function name used in the error message.
              -> (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 (X11Front k -> IO a) -> IO a
forall k a. (X11Front k -> IO a) -> IO a
impl else (X11Front k -> IO a) -> IO a
forall {p} {a}. p -> IO a
error_impl where
  impl :: (X11Front k -> IO r) -> IO r
impl = ContT r IO (X11Front k) -> (X11Front k -> IO r) -> IO r
forall {k} (r :: k) (m :: k -> *) a.
ContT r m a -> (a -> m r) -> m r
runContT (ContT r IO (X11Front k) -> (X11Front k -> IO r) -> IO r)
-> ContT r IO (X11Front k) -> (X11Front k -> IO r) -> IO r
forall a b. (a -> b) -> a -> b
$ do
    IO () -> ContT r IO ()
forall a. IO a -> ContT r IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ContT r IO ()) -> IO () -> ContT r IO ()
forall a b. (a -> b) -> a -> b
$ IO ()
doInitThreads
    Display
disp <- ((Display -> IO r) -> IO r) -> ContT r IO Display
forall {k} (r :: k) (m :: k -> *) a.
((a -> m r) -> m r) -> ContT r m a
ContT (((Display -> IO r) -> IO r) -> ContT r IO Display)
-> ((Display -> IO r) -> IO r) -> ContT r IO Display
forall a b. (a -> b) -> a -> b
$ IO Display -> (Display -> IO ()) -> (Display -> IO r) -> IO r
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 <- IO KeyMaskMap -> ContT r IO KeyMaskMap
forall a. IO a -> ContT r IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO KeyMaskMap -> ContT r IO KeyMaskMap)
-> IO KeyMaskMap -> ContT r IO KeyMaskMap
forall a b. (a -> b) -> a -> b
$ Display -> IO KeyMaskMap
getKeyMaskMap Display
disp
    Display
notif_disp <- ((Display -> IO r) -> IO r) -> ContT r IO Display
forall {k} (r :: k) (m :: k -> *) a.
((a -> m r) -> m r) -> ContT r m a
ContT (((Display -> IO r) -> IO r) -> ContT r IO Display)
-> ((Display -> IO r) -> IO r) -> ContT r IO Display
forall a b. (a -> b) -> a -> b
$ IO Display -> (Display -> IO ()) -> (Display -> IO r) -> IO r
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket IO Display
openMyDisplay Display -> IO ()
Xlib.closeDisplay
    Debouncer
debouncer <- ((Debouncer -> IO r) -> IO r) -> ContT r IO Debouncer
forall {k} (r :: k) (m :: k -> *) a.
((a -> m r) -> m r) -> ContT r m a
ContT (((Debouncer -> IO r) -> IO r) -> ContT r IO Debouncer)
-> ((Debouncer -> IO r) -> IO r) -> ContT r IO Debouncer
forall a b. (a -> b) -> a -> b
$ Display -> (Debouncer -> IO r) -> IO r
forall a. Display -> (Debouncer -> IO a) -> IO a
Ndeb.withDebouncer Display
notif_disp
    IO () -> ContT r IO ()
forall a. IO a -> ContT r IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ContT r IO ()) -> IO () -> ContT r IO ()
forall a b. (a -> b) -> a -> b
$ Display -> EventMask -> EventMask -> IO ()
Xlib.selectInput Display
disp (Display -> EventMask
Xlib.defaultRootWindow Display
disp)
      (EventMask
Xlib.substructureNotifyMask EventMask -> EventMask -> EventMask
forall a. Bits a => a -> a -> a
.|. EventMask
Ndeb.xEventMask)
    IORef (Maybe ActiveWindow)
awin_ref <- IO (IORef (Maybe ActiveWindow))
-> ContT r IO (IORef (Maybe ActiveWindow))
forall a. IO a -> ContT r IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef (Maybe ActiveWindow))
 -> ContT r IO (IORef (Maybe ActiveWindow)))
-> IO (IORef (Maybe ActiveWindow))
-> ContT r IO (IORef (Maybe ActiveWindow))
forall a b. (a -> b) -> a -> b
$ Maybe ActiveWindow -> IO (IORef (Maybe ActiveWindow))
forall a. a -> IO (IORef a)
newIORef Maybe ActiveWindow
forall a. Maybe a
Nothing
    TChan (FrontEvent ActiveWindow k)
pending_events <- IO (TChan (FrontEvent ActiveWindow k))
-> ContT r IO (TChan (FrontEvent ActiveWindow k))
forall a. IO a -> ContT r IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (TChan (FrontEvent ActiveWindow k))
 -> ContT r IO (TChan (FrontEvent ActiveWindow k)))
-> IO (TChan (FrontEvent ActiveWindow k))
-> ContT r IO (TChan (FrontEvent ActiveWindow k))
forall a b. (a -> b) -> a -> b
$ IO (TChan (FrontEvent ActiveWindow k))
forall a. IO (TChan a)
newTChanIO
    IORef (GrabMan k)
grab_man <- IO (IORef (GrabMan k)) -> ContT r IO (IORef (GrabMan k))
forall a. IO a -> ContT r IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef (GrabMan k)) -> ContT r IO (IORef (GrabMan k)))
-> IO (IORef (GrabMan k)) -> ContT r IO (IORef (GrabMan k))
forall a b. (a -> b) -> a -> b
$ KeyMaskMap -> Display -> EventMask -> IO (IORef (GrabMan k))
forall k.
KeyMaskMap -> Display -> EventMask -> IO (IORef (GrabMan k))
GM.new KeyMaskMap
keymask_map Display
disp (Display -> EventMask
Xlib.defaultRootWindow Display
disp)
    IO () -> ContT r IO ()
forall a. IO a -> ContT r IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ContT r IO ()) -> IO () -> ContT r IO ()
forall a b. (a -> b) -> a -> b
$ Debouncer -> IO ()
Ndeb.notify Debouncer
debouncer
    X11Front k -> ContT r IO (X11Front k)
forall a. a -> ContT r IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (X11Front k -> ContT r IO (X11Front k))
-> X11Front k -> ContT r IO (X11Front k)
forall a b. (a -> b) -> a -> b
$ Display
-> Debouncer
-> IORef (Maybe ActiveWindow)
-> TChan (FrontEvent ActiveWindow k)
-> KeyMaskMap
-> IORef (GrabMan k)
-> X11Front k
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
_ = IOError -> IO a
forall e a. Exception e => e -> IO a
throwIO (IOError -> IO a) -> IOError -> IO a
forall a b. (a -> b) -> a -> b
$ String -> IOError
userError (String
"You need to build with -threaded option when you use " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
func_name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" function.")
  doInitThreads :: IO ()
doInitThreads = do
    Status
ret <- IO Status
Xlib.initThreads
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Status
ret Status -> Status -> Bool
forall a. Eq a => a -> a -> Bool
== Status
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      IOError -> IO ()
forall e a. Exception e => e -> IO a
throwIO (IOError -> IO ()) -> IOError -> IO ()
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 = [a] -> WriterT [a] m ()
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 EventType -> EventType -> Bool
forall a. Eq a => a -> a -> Bool
== EventType
Xlib.keyPress = InternalEvent -> IO InternalEvent
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (InternalEvent -> IO InternalEvent)
-> InternalEvent -> IO InternalEvent
forall a b. (a -> b) -> a -> b
$ KeyEventType -> InternalEvent
IEKey KeyEventType
KeyPress
                   | EventType
xtype EventType -> EventType -> Bool
forall a. Eq a => a -> a -> Bool
== EventType
Xlib.keyRelease = InternalEvent -> IO InternalEvent
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (InternalEvent -> IO InternalEvent)
-> InternalEvent -> IO InternalEvent
forall a b. (a -> b) -> a -> b
$ KeyEventType -> InternalEvent
IEKey KeyEventType
KeyRelease
                   | EventType
xtype EventType -> EventType -> Bool
forall a. Eq a => a -> a -> Bool
== EventType
Xlib.configureNotify Bool -> Bool -> Bool
|| EventType
xtype EventType -> EventType -> Bool
forall a. Eq a => a -> a -> Bool
== EventType
Xlib.destroyNotify = InternalEvent -> IO InternalEvent
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (InternalEvent -> IO InternalEvent)
-> InternalEvent -> IO InternalEvent
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 InternalEvent -> IO InternalEvent
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return InternalEvent
IEDebounced
                         else InternalEvent -> IO InternalEvent
forall a. a -> IO a
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 = WriterT [FrontEvent ActiveWindow k] IO ()
-> IO [FrontEvent ActiveWindow k]
forall (m :: * -> *) w a. Monad m => WriterT w m a -> m w
execWriterT (WriterT [FrontEvent ActiveWindow k] IO ()
 -> IO [FrontEvent ActiveWindow k])
-> WriterT [FrontEvent ActiveWindow k] IO ()
-> IO [FrontEvent ActiveWindow k]
forall a b. (a -> b) -> a -> b
$ WriterT [FrontEvent ActiveWindow k] IO ()
forall k. XKeyInput k => WriterT [FrontEvent ActiveWindow k] IO ()
convertEventWriter where
  tellChangeEvent :: WriterT [FrontEvent ActiveWindow i] IO ()
tellChangeEvent = (FrontEvent ActiveWindow i
-> WriterT [FrontEvent ActiveWindow i] IO ()
forall (m :: * -> *) a. Monad m => a -> WriterT [a] m ()
tellElem (FrontEvent ActiveWindow i
 -> WriterT [FrontEvent ActiveWindow i] IO ())
-> (ActiveWindow -> FrontEvent ActiveWindow i)
-> ActiveWindow
-> WriterT [FrontEvent ActiveWindow i] IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ActiveWindow -> FrontEvent ActiveWindow i
forall s i. s -> FrontEvent s i
FEChange) (ActiveWindow -> WriterT [FrontEvent ActiveWindow i] IO ())
-> WriterT [FrontEvent ActiveWindow i] IO ActiveWindow
-> WriterT [FrontEvent ActiveWindow i] IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (IO ActiveWindow
-> WriterT [FrontEvent ActiveWindow i] IO ActiveWindow
forall a. IO a -> WriterT [FrontEvent ActiveWindow i] IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ActiveWindow
 -> WriterT [FrontEvent ActiveWindow i] IO ActiveWindow)
-> IO ActiveWindow
-> WriterT [FrontEvent ActiveWindow i] IO ActiveWindow
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 <- IO InternalEvent
-> WriterT [FrontEvent ActiveWindow k] IO InternalEvent
forall a. IO a -> WriterT [FrontEvent ActiveWindow k] IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO InternalEvent
 -> WriterT [FrontEvent ActiveWindow k] IO InternalEvent)
-> IO InternalEvent
-> WriterT [FrontEvent ActiveWindow k] IO InternalEvent
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
       WriterT [FrontEvent ActiveWindow k] IO ()
forall {i}. WriterT [FrontEvent ActiveWindow i] IO ()
tellChangeEvent
       (WriterT [FrontEvent ActiveWindow k] IO ()
-> (FrontEvent ActiveWindow k
    -> WriterT [FrontEvent ActiveWindow k] IO ())
-> Maybe (FrontEvent ActiveWindow k)
-> WriterT [FrontEvent ActiveWindow k] IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> WriterT [FrontEvent ActiveWindow k] IO ()
forall a. a -> WriterT [FrontEvent ActiveWindow k] IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()) FrontEvent ActiveWindow k
-> WriterT [FrontEvent ActiveWindow k] IO ()
forall (m :: * -> *) a. Monad m => a -> WriterT [a] m ()
tellElem) (Maybe (FrontEvent ActiveWindow k)
 -> WriterT [FrontEvent ActiveWindow k] IO ())
-> WriterT
     [FrontEvent ActiveWindow k] IO (Maybe (FrontEvent ActiveWindow k))
-> WriterT [FrontEvent ActiveWindow k] IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (IO (Maybe (FrontEvent ActiveWindow k))
-> WriterT
     [FrontEvent ActiveWindow k] IO (Maybe (FrontEvent ActiveWindow k))
forall a. IO a -> WriterT [FrontEvent ActiveWindow k] IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe (FrontEvent ActiveWindow k))
 -> WriterT
      [FrontEvent ActiveWindow k] IO (Maybe (FrontEvent ActiveWindow k)))
-> IO (Maybe (FrontEvent ActiveWindow k))
-> WriterT
     [FrontEvent ActiveWindow k] IO (Maybe (FrontEvent ActiveWindow k))
forall a b. (a -> b) -> a -> b
$ MaybeT IO (FrontEvent ActiveWindow k)
-> IO (Maybe (FrontEvent ActiveWindow k))
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (k -> FrontEvent ActiveWindow k
forall s i. i -> FrontEvent s i
FEInput (k -> FrontEvent ActiveWindow k)
-> MaybeT IO k -> MaybeT IO (FrontEvent ActiveWindow k)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> KeyMaskMap -> KeyEventType -> XKeyEventPtr -> MaybeT IO k
forall k.
XKeyInput k =>
KeyMaskMap -> KeyEventType -> XKeyEventPtr -> MaybeT IO k
xKeyEventToXKeyInput KeyMaskMap
kmmap KeyEventType
ev_type XKeyEventPtr
key_ev))
     InternalEvent
IEDebounced -> WriterT [FrontEvent ActiveWindow k] IO ()
forall {i}. WriterT [FrontEvent ActiveWindow i] IO ()
tellChangeEvent
     InternalEvent
IEActiveWindow -> IO () -> WriterT [FrontEvent ActiveWindow k] IO ()
forall a. IO a -> WriterT [FrontEvent ActiveWindow k] IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Debouncer -> IO ()
Ndeb.notify Debouncer
deb) WriterT [FrontEvent ActiveWindow k] IO ()
-> WriterT [FrontEvent ActiveWindow k] IO ()
-> WriterT [FrontEvent ActiveWindow k] IO ()
forall a b.
WriterT [FrontEvent ActiveWindow k] IO a
-> WriterT [FrontEvent ActiveWindow k] IO b
-> WriterT [FrontEvent ActiveWindow k] IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> WriterT [FrontEvent ActiveWindow k] IO ()
forall a. a -> WriterT [FrontEvent ActiveWindow k] IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
     InternalEvent
IEUnknown -> () -> WriterT [FrontEvent ActiveWindow k] IO ()
forall a. a -> WriterT [FrontEvent ActiveWindow k] IO a
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 <- IO (Maybe ActiveWindow) -> IO (Maybe ActiveWindow)
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe ActiveWindow) -> IO (Maybe ActiveWindow))
-> IO (Maybe ActiveWindow) -> IO (Maybe ActiveWindow)
forall a b. (a -> b) -> a -> b
$ IORef (Maybe ActiveWindow) -> IO (Maybe ActiveWindow)
forall a. IORef a -> IO a
readIORef (IORef (Maybe ActiveWindow) -> IO (Maybe ActiveWindow))
-> IORef (Maybe ActiveWindow) -> IO (Maybe ActiveWindow)
forall a b. (a -> b) -> a -> b
$ X11Front k -> IORef (Maybe ActiveWindow)
forall k. X11Front k -> IORef (Maybe ActiveWindow)
x11PrevActiveWindow X11Front k
front
  case Maybe ActiveWindow
m_old_state of
   Maybe ActiveWindow
Nothing        -> Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
   Just ActiveWindow
old_state -> Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ ActiveWindow
new_state ActiveWindow -> ActiveWindow -> Bool
forall a. Eq a => a -> a -> Bool
== ActiveWindow
old_state)
isSignificantEvent X11Front k
_ FrontEvent ActiveWindow k
_ = Bool -> IO Bool
forall a. a -> IO a
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
_)  -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  (FEChange ActiveWindow
s) -> IORef (Maybe ActiveWindow) -> Maybe ActiveWindow -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (X11Front k -> IORef (Maybe ActiveWindow)
forall k. X11Front k -> IORef (Maybe ActiveWindow)
x11PrevActiveWindow X11Front k
front) (ActiveWindow -> Maybe ActiveWindow
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 <- X11Front k -> IO (Maybe (FrontEvent ActiveWindow k))
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 -> FrontEvent ActiveWindow k -> IO (FrontEvent ActiveWindow k)
forall a. a -> IO a
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 = (XEventPtr -> IO (FrontEvent ActiveWindow k))
-> IO (FrontEvent ActiveWindow k)
forall a. (XEventPtr -> IO a) -> IO a
Xlib.allocaXEvent ((XEventPtr -> IO (FrontEvent ActiveWindow k))
 -> IO (FrontEvent ActiveWindow k))
-> (XEventPtr -> IO (FrontEvent ActiveWindow k))
-> IO (FrontEvent ActiveWindow k)
forall a b. (a -> b) -> a -> b
$ \XEventPtr
xev -> do
    Display -> XEventPtr -> IO ()
Xlib.nextEvent (X11Front k -> Display
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
        X11Front k -> [FrontEvent ActiveWindow k] -> IO ()
forall k. X11Front k -> [FrontEvent ActiveWindow k] -> IO ()
x11UnshiftPendingEvents X11Front k
handle [FrontEvent ActiveWindow k]
rest
        FrontEvent ActiveWindow k -> IO (FrontEvent ActiveWindow k)
forall a. a -> IO a
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 <- (FrontEvent ActiveWindow k -> IO Bool)
-> [FrontEvent ActiveWindow k] -> IO [FrontEvent ActiveWindow k]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM (X11Front k -> FrontEvent ActiveWindow k -> IO Bool
forall k. X11Front k -> FrontEvent ActiveWindow k -> IO Bool
isSignificantEvent X11Front k
handle)
               ([FrontEvent ActiveWindow k] -> IO [FrontEvent ActiveWindow k])
-> IO [FrontEvent ActiveWindow k] -> IO [FrontEvent ActiveWindow k]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< KeyMaskMap
-> Display
-> Debouncer
-> XEventPtr
-> IO [FrontEvent ActiveWindow k]
forall k.
XKeyInput k =>
KeyMaskMap
-> Display
-> Debouncer
-> XEventPtr
-> IO [FrontEvent ActiveWindow k]
convertEvent (X11Front k -> KeyMaskMap
forall k. X11Front k -> KeyMaskMap
x11KeyMaskMap X11Front k
handle) (X11Front k -> Display
forall k. X11Front k -> Display
x11Display X11Front k
handle) (X11Front k -> Debouncer
forall k. X11Front k -> Debouncer
x11Debouncer X11Front k
handle) XEventPtr
xev
    (FrontEvent ActiveWindow k -> IO ())
-> [FrontEvent ActiveWindow k] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (X11Front k -> FrontEvent ActiveWindow k -> IO ()
forall k. X11Front k -> FrontEvent ActiveWindow k -> IO ()
updateState X11Front k
handle) [FrontEvent ActiveWindow k]
fevents
    [FrontEvent ActiveWindow k] -> IO [FrontEvent ActiveWindow k]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [FrontEvent ActiveWindow k]
fevents

-- | Create 'FrontEnd' from 'X11Front' object.
--
-- @since 0.2.0.0
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 = k -> ActionDescription
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 = X11Front k -> IO (FrontEvent ActiveWindow k)
forall k.
XKeyInput k =>
X11Front k -> IO (FrontEvent ActiveWindow k)
nextEvent X11Front k
f
                          }
  where
    runGrab :: GrabOp -> k -> IO ()
runGrab = IORef (GrabMan k) -> GrabOp -> k -> IO ()
forall k.
(XKeyInput k, Ord k) =>
IORef (GrabMan k) -> GrabOp -> k -> IO ()
GM.modify (X11Front k -> IORef (GrabMan k)
forall k. X11Front k -> IORef (GrabMan k)
x11GrabMan X11Front k
f)

-- | Get the default root window.
--
-- @since 0.2.0.0
defaultRootWindow :: X11Front k -> Window
defaultRootWindow :: forall k. X11Front k -> ActiveWindow
defaultRootWindow = Display -> ActiveWindow
defaultRootWindowForDisplay (Display -> ActiveWindow)
-> (X11Front k -> Display) -> X11Front k -> ActiveWindow
forall b c a. (b -> c) -> (a -> b) -> a -> c
. X11Front k -> Display
forall k. X11Front k -> Display
x11Display