From 861331083a3a2c7260e0d34ec2c046a6ee7a690f Mon Sep 17 00:00:00 2001
From: Jens Nolte <git@queezle.net>
Date: Thu, 9 Sep 2021 15:15:11 +0200
Subject: [PATCH] Propagate IsInterfaceSide further and generate instances
---
src/Quasar/Wayland/Client.hs | 4 ++--
src/Quasar/Wayland/Connection.hs | 7 ++++++-
src/Quasar/Wayland/Core.hs | 5 +++--
src/Quasar/Wayland/TH.hs | 7 ++++++-
4 files changed, 17 insertions(+), 6 deletions(-)
diff --git a/src/Quasar/Wayland/Client.hs b/src/Quasar/Wayland/Client.hs
index 44b8bf1..b150641 100644
--- a/src/Quasar/Wayland/Client.hs
+++ b/src/Quasar/Wayland/Client.hs
@@ -31,9 +31,9 @@ instance IsDisposable WaylandClient where
toDisposable (WaylandClient connection) = toDisposable connection
newWaylandClient :: MonadResourceManager m => Socket -> m WaylandClient
-newWaylandClient socket = WaylandClient <$> newWaylandConnection clientCallback clientCallback socket
+newWaylandClient socket = WaylandClient <$> newWaylandConnection @I_wl_display @I_wl_registry clientCallback clientCallback socket
-clientCallback :: IsInterface i => ClientCallback STM i
+clientCallback :: IsInterfaceSide 'Client i => ClientCallback STM i
clientCallback = Callback {
messageCallback = \object message ->
lift $ traceM $ objectInterfaceName object <> "@" <> show (objectId object) <> "." <> showMessage message
diff --git a/src/Quasar/Wayland/Connection.hs b/src/Quasar/Wayland/Connection.hs
index 45eccaa..bc3d01a 100644
--- a/src/Quasar/Wayland/Connection.hs
+++ b/src/Quasar/Wayland/Connection.hs
@@ -34,7 +34,12 @@ data SocketClosed = SocketClosed
deriving stock Show
deriving anyclass Exception
-newWaylandConnection :: forall s m. (IsSide s, MonadResourceManager m) => Callback s STM I_wl_display -> Callback s STM I_wl_registry -> Socket -> m (WaylandConnection s)
+newWaylandConnection
+ :: forall wl_display wl_registry s m. (IsInterfaceSide s wl_display, IsInterfaceSide s wl_registry, MonadResourceManager m)
+ => Callback s STM wl_display
+ -> Callback s STM wl_registry
+ -> Socket
+ -> m (WaylandConnection s)
newWaylandConnection wlDisplayCallback wlRegistryCallback socket = do
protocolStateVar <- liftIO $ newTVarIO $ initialProtocolState wlDisplayCallback wlRegistryCallback
outboxVar <- liftIO newEmptyTMVarIO
diff --git a/src/Quasar/Wayland/Core.hs b/src/Quasar/Wayland/Core.hs
index 0b600fb..7a28aa5 100644
--- a/src/Quasar/Wayland/Core.hs
+++ b/src/Quasar/Wayland/Core.hs
@@ -2,9 +2,10 @@ module Quasar.Wayland.Core (
ObjectId,
Opcode,
Fixed,
- IsInterface(..),
- Side(..),
IsSide,
+ Side(..),
+ IsInterface(..),
+ IsInterfaceSide(..),
Object,
IsObject(..),
IsObject,
diff --git a/src/Quasar/Wayland/TH.hs b/src/Quasar/Wayland/TH.hs
index 5e33cd7..67eb473 100644
--- a/src/Quasar/Wayland/TH.hs
+++ b/src/Quasar/Wayland/TH.hs
@@ -59,7 +59,7 @@ tellQs = tell <=< lift
interfaceDec :: InterfaceSpec -> Q [Dec]
interfaceDec interface = execWriterT do
- tellQ $ dataD (pure []) iName [] Nothing [normalC iName []] []
+ tellQ $ dataD (pure []) iName [] Nothing [normalC iName []] [derivingInterfaceClient, derivingInterfaceServer]
tellQ $ instanceD (pure []) [t|IsInterface $iT|] instanceDecs
when (length interface.requests > 0) do
@@ -125,6 +125,11 @@ interfaceT interface = conT (interfaceN interface)
derivingShow :: Q DerivClause
derivingShow = derivClause (Just StockStrategy) [[t|Show|]]
+derivingInterfaceClient :: Q DerivClause
+derivingInterfaceClient = derivClause (Just AnyclassStrategy) [[t|IsInterfaceSide 'Client|]]
+
+derivingInterfaceServer :: Q DerivClause
+derivingInterfaceServer = derivClause (Just AnyclassStrategy) [[t|IsInterfaceSide 'Server|]]
--
GitLab