From ced31927effc976e3daa1af557336d86b8884ea5 Mon Sep 17 00:00:00 2001
From: Jens Nolte <git@queezle.net>
Date: Tue, 14 Dec 2021 17:24:56 +0100
Subject: [PATCH] Implement high-level wrapper for wl_display.sync
---
src/Quasar/Wayland/Display.hs | 11 +++++++++++
src/Quasar/Wayland/Protocol.hs | 4 +++-
src/Quasar/Wayland/Protocol/Core.hs | 10 +++++++++-
3 files changed, 23 insertions(+), 2 deletions(-)
diff --git a/src/Quasar/Wayland/Display.hs b/src/Quasar/Wayland/Display.hs
index c42353e..8350525 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 3c042cd..68e59f5 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 d38c423..b1e8dfb 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
--
GitLab