diff --git a/src/Quasar/Wayland/Protocol/Core.hs b/src/Quasar/Wayland/Protocol/Core.hs index 5f763039bef01a499062204ba6cec0a5505eb474..4fe0dcd29e966144d01097d67cd1c2c2cbdff4d0 100644 --- a/src/Quasar/Wayland/Protocol/Core.hs +++ b/src/Quasar/Wayland/Protocol/Core.hs @@ -1,5 +1,4 @@ {-# LANGUAGE DeriveLift #-} -{-# LANGUAGE UndecidableInstances #-} module Quasar.Wayland.Protocol.Core ( ObjectId, @@ -17,8 +16,7 @@ module Quasar.Wayland.Protocol.Core ( interfaceName, IsInterfaceSide(..), IsInterfaceHandler(..), - Object, - objectMessageHandler, + Object(messageHandler), IsObject, IsMessage(..), ProtocolHandle, @@ -191,8 +189,8 @@ class ( KnownSymbol (InterfaceName i) ) => IsInterface i where - type Requests (s :: Side) i - type Events (s :: Side) i + type RequestHandler i + type EventHandler i type WireRequest i type WireEvent i type InterfaceName i :: Symbol @@ -201,14 +199,14 @@ interfaceName :: forall i. IsInterface i => String interfaceName = symbolVal @(InterfaceName i) Proxy class IsSide (s :: Side) where - type Down s i + type MessageHandler s i type WireUp s i type WireDown s i initialId :: Word32 maximumId :: Word32 instance IsSide 'Client where - type Down 'Client i = Events 'Client i + type MessageHandler 'Client i = EventHandler i type WireUp 'Client i = WireRequest i type WireDown 'Client i = WireEvent i -- Id #1 is reserved for wl_display @@ -216,7 +214,7 @@ instance IsSide 'Client where maximumId = 0xfeffffff instance IsSide 'Server where - type Down 'Server i = Requests 'Server i + type MessageHandler 'Server i = RequestHandler i type WireUp 'Server i = WireEvent i type WireDown 'Server i = WireRequest i initialId = 0xff000000 @@ -251,14 +249,10 @@ data Side = Client | Server data Object s i = IsInterfaceSide s i => Object { objectProtocol :: (ProtocolHandle s), objectObjectId :: GenericObjectId, - objectDown :: (Down s i), + messageHandler :: (MessageHandler s i), objectWireCallback :: (WireCallback s i) } -objectMessageHandler :: Object s i -> Down s i -objectMessageHandler = (.objectDown) - - instance IsInterface i => Show (Object s i) where show = showObject diff --git a/src/Quasar/Wayland/Protocol/Display.hs b/src/Quasar/Wayland/Protocol/Display.hs index bc3c04c04964e76b85c2df2be87bac589593f6f9..5e81ea994ff78b36b6496d258a8102ae7a8681d8 100644 --- a/src/Quasar/Wayland/Protocol/Display.hs +++ b/src/Quasar/Wayland/Protocol/Display.hs @@ -18,5 +18,5 @@ clientWlDisplayWireCallback = internalFnWireCallback handler -- | wl_display is specified to never change, so manually specifying the callback is safe handler :: Object 'Client Interface_wl_display -> WireEvent_wl_display -> ProtocolM 'Client () -- TODO parse oId - handler _ (WireEvent_wl_display_error oId code message) = throwM $ ServerError code (toString message) - handler _ (WireEvent_wl_display_delete_id deletedId) = pure () -- TODO confirm delete + handler _ (WireEvent_wl_display__error oId code message) = throwM $ ServerError code (toString message) + handler _ (WireEvent_wl_display__delete_id deletedId) = pure () -- TODO confirm delete diff --git a/src/Quasar/Wayland/Protocol/TH.hs b/src/Quasar/Wayland/Protocol/TH.hs index 77ab7d313d275137d4a974213feefd4942095595..8cbbb98e0d97d3a6a66d6866d8df0477bb166967 100644 --- a/src/Quasar/Wayland/Protocol/TH.hs +++ b/src/Quasar/Wayland/Protocol/TH.hs @@ -112,8 +112,8 @@ interfaceDecs interface = do tellQ $ dataD_doc (pure []) iName [] Nothing [iCtorDec] [] (toWlDoc interface.description) -- IsInterface instance tellQ $ instanceD (pure []) [t|IsInterface $iT|] [ - tySynInstD (tySynEqn Nothing [t|$(conT ''Requests) $sT $iT|] (orUnit (requestsT interface sT))), - tySynInstD (tySynEqn Nothing [t|$(conT ''Events) $sT $iT|] (orUnit (eventsT interface sT))), + tySynInstD (tySynEqn Nothing [t|$(conT ''RequestHandler) $iT|] (orUnit (requestsT interface))), + tySynInstD (tySynEqn Nothing [t|$(conT ''EventHandler) $iT|] (orUnit (eventsT interface))), tySynInstD (tySynEqn Nothing (appT (conT ''WireRequest) iT) wireRequestT), tySynInstD (tySynEqn Nothing (appT (conT ''WireEvent) iT) wireEventT), tySynInstD (tySynEqn Nothing (appT (conT ''InterfaceName) iT) (litT (strTyLit interface.name))) @@ -153,13 +153,13 @@ interfaceDecs interface = do rTypeName :: Name rTypeName = mkName $ "WireRequest_" <> interface.name rConName :: RequestSpec -> Name - rConName (RequestSpec request) = mkName $ "WireRequest_" <> interface.name <> "_" <> request.name + rConName (RequestSpec request) = mkName $ "WireRequest_" <> interface.name <> "__" <> request.name wireEventT :: Q Type wireEventT = if length interface.events > 0 then conT eTypeName else [t|Void|] eTypeName :: Name eTypeName = mkName $ "WireEvent_" <> interface.name eConName :: EventSpec -> Name - eConName (EventSpec event) = mkName $ "WireEvent_" <> interface.name <> "_" <> event.name + eConName (EventSpec event) = mkName $ "WireEvent_" <> interface.name <> "__" <> event.name wireRequestContext :: RequestSpec -> MessageContext wireRequestContext req@(RequestSpec msgSpec) = MessageContext { msgInterfaceT = iT, @@ -214,7 +214,7 @@ interfaceDecs interface = do fieldNameLitT :: Q Type fieldNameLitT = litT (strTyLit (messageFieldNameString msg)) fieldE :: Q Exp - fieldE = [|$(appTypeE [|getField|] fieldNameLitT) (objectMessageHandler $objectE)|] + fieldE = [|$(appTypeE [|getField|] fieldNameLitT) $objectE.messageHandler|] bodyE :: Q Exp bodyE = applyMsgArgs msg fieldE @@ -244,7 +244,7 @@ messageFieldNameString :: MessageContext -> String messageFieldNameString msg = msg.msgSpec.name messageRecordD :: Name -> [MessageContext] -> Q Dec -messageRecordD name messageContexts = dataD (cxt []) name [plainTV sideTVarName] Nothing [con] [] +messageRecordD name messageContexts = dataD (cxt []) name [] Nothing [con] [] where con = recC name (recField <$> messageContexts) recField :: MessageContext -> Q VarBangType @@ -269,16 +269,16 @@ interfaceTFromName :: String -> Q Type interfaceTFromName name = conT (mkName ("Interface_" <> name)) requestsName :: InterfaceSpec -> Name -requestsName interface = mkName $ "Requests_" <> interface.name +requestsName interface = mkName $ "RequestHandler_" <> interface.name -requestsT :: InterfaceSpec -> Q Type -> Maybe (Q Type) -requestsT interface sideT = if (length interface.requests) > 0 then Just [t|$(conT (requestsName interface)) $sideT|] else Nothing +requestsT :: InterfaceSpec -> Maybe (Q Type) +requestsT interface = if (length interface.requests) > 0 then Just [t|$(conT (requestsName interface))|] else Nothing eventsName :: InterfaceSpec -> Name -eventsName interface = mkName $ "Events_" <> interface.name +eventsName interface = mkName $ "EventHandler_" <> interface.name -eventsT :: InterfaceSpec -> Q Type -> Maybe (Q Type) -eventsT interface sideT = if (length interface.events) > 0 then Just [t|$(conT (eventsName interface)) $sideT|] else Nothing +eventsT :: InterfaceSpec -> Maybe (Q Type) +eventsT interface = if (length interface.events) > 0 then Just [t|$(conT (eventsName interface))|] else Nothing orVoid :: Maybe (Q Type) -> Q Type orVoid = fromMaybe [t|Void|] diff --git a/src/Quasar/Wayland/Registry.hs b/src/Quasar/Wayland/Registry.hs index 815f80872bead7d8f5cccb6b9b700d324a4cbddc..89b7ef5032ab527b9ff063c66bff899764b7cf11 100644 --- a/src/Quasar/Wayland/Registry.hs +++ b/src/Quasar/Wayland/Registry.hs @@ -23,7 +23,7 @@ createClientRegistry wlDisplay = mfix \clientRegistry -> do globalsVar <- lift $ newTVar HM.empty (wlRegistry, newId) <- newObject @'Client @Interface_wl_registry (callback clientRegistry) - sendMessage wlDisplay $ WireRequest_wl_display_get_registry newId + sendMessage wlDisplay $ WireRequest_wl_display__get_registry newId pure ClientRegistry { wlRegistry, @@ -35,9 +35,9 @@ createClientRegistry wlDisplay = mfix \clientRegistry -> do where -- | wl_registry is specified to never change, so manually specifying the callback is safe handler :: Object 'Client Interface_wl_registry -> WireEvent_wl_registry -> ProtocolM 'Client () - handler _ (WireEvent_wl_registry_global name interface version) = do + handler _ (WireEvent_wl_registry__global name interface version) = do lift $ modifyTVar clientRegistry.globalsVar (HM.insert name (interface, version)) - handler _ (WireEvent_wl_registry_global_remove name) = do + handler _ (WireEvent_wl_registry__global_remove name) = do result <- lift $ stateTVar clientRegistry.globalsVar (swap . lookupDelete name) case result of Nothing -> traceM $ "Invalid global removed by server: " <> show name