diff --git a/src/Quasar/Wayland/Display.hs b/src/Quasar/Wayland/Display.hs index c42353eda6864de033e6644eccf4199614e2cb59..83505253a278a442c2db20dd5a6fdc71ba5a8bf7 100644 --- a/src/Quasar/Wayland/Display.hs +++ b/src/Quasar/Wayland/Display.hs @@ -4,6 +4,8 @@ module Quasar.Wayland.Display ( ) where import Control.Concurrent.STM +import GHC.Records +import Quasar.Awaitable import Quasar.Prelude import Quasar.Wayland.Protocol import Quasar.Wayland.Protocol.Display @@ -23,3 +25,12 @@ newClientDisplay = wlDisplay, registry } + +instance HasField "sync" ClientDisplay (STM (Awaitable ())) where + getField display = do + var <- newAsyncVarSTM + wlCallback <- display.wlDisplay.sync + setEventHandler wlCallback EventHandler_wl_callback { + done = const $ putAsyncVarSTM_ var () + } + pure $ toAwaitable var diff --git a/src/Quasar/Wayland/Protocol.hs b/src/Quasar/Wayland/Protocol.hs index 3c042cdbaa77e8a20d90eafdabd7d2cac6024087..68e59f5556e9b4aaae92014dcd8f843315e6ef6b 100644 --- a/src/Quasar/Wayland/Protocol.hs +++ b/src/Quasar/Wayland/Protocol.hs @@ -4,8 +4,10 @@ module Quasar.Wayland.Protocol ( -- "Quasar.Wayland.Protocol.TH". Object, - getMessageHandler, + setEventHandler, + setRequestHandler, setMessageHandler, + getMessageHandler, -- ** Wayland types Fixed(..), diff --git a/src/Quasar/Wayland/Protocol/Core.hs b/src/Quasar/Wayland/Protocol/Core.hs index d38c423cc7a3595a0d29760ccd7a3f2d85afd1c3..b1e8dfbb8841dab9b484c15d123fa3fdb1dd8fd2 100644 --- a/src/Quasar/Wayland/Protocol/Core.hs +++ b/src/Quasar/Wayland/Protocol/Core.hs @@ -17,8 +17,10 @@ module Quasar.Wayland.Protocol.Core ( IsInterfaceSide(..), IsInterfaceHandler(..), Object(objectId), - getMessageHandler, + setEventHandler, + setRequestHandler, setMessageHandler, + getMessageHandler, NewObject, IsObject, IsMessage(..), @@ -258,6 +260,12 @@ getMessageHandler object = maybe retry pure =<< readTVar object.messageHandler setMessageHandler :: Object s i -> MessageHandler s i -> STM () setMessageHandler object = writeTVar object.messageHandler . Just +setRequestHandler :: Object 'Server i -> RequestHandler i -> STM () +setRequestHandler = setMessageHandler + +setEventHandler :: Object 'Client i -> EventHandler i -> STM () +setEventHandler = setMessageHandler + -- | Type alias to indicate an object is created with a message. type NewObject s i = Object s i