diff --git a/src/Quasar/Wayland/Client.hs b/src/Quasar/Wayland/Client.hs index 44b8bf1f4c8afc256f8d1ebe30fd8e469e3f0818..b1506415f26df176c73cfd29427e4cd9c601b4ce 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 45eccaa2506c215c49c81eecd7c8faae0b688380..bc3d01ae30270db806c83b90bda46829f8df814d 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 0b600fbcc1edb8c586b034a512becce3d3fbfeec..7a28aa53dda09676aeeb200ef1c3d1434b625476 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 5e33cd75369497d60492d3e76b88b889fa108d1e..67eb47351d52296ad7e62048ec651e8b7a7ba3b0 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|]]