diff --git a/src/Quasar/Wayland/Protocol/Core.hs b/src/Quasar/Wayland/Protocol/Core.hs index 21f15b682533daab65765710ef0120a0b47e5413..a00af4c6cc6053dbe9c04962ab2745714cb15f63 100644 --- a/src/Quasar/Wayland/Protocol/Core.hs +++ b/src/Quasar/Wayland/Protocol/Core.hs @@ -183,6 +183,8 @@ class ( IsMessage (WireEvent i) ) => IsInterface i where + type Requests i + type Events i type WireRequest i type WireEvent i type InterfaceName i :: Symbol @@ -215,7 +217,7 @@ class ( IsMessage (WireUp s i), IsMessage (WireDown s i) ) - => IsInterfaceSide (s :: Side) i + => IsInterfaceSide (s :: Side) i where getWireDown :: forall s i. IsInterfaceSide s i => Object s i -> Opcode -> Get (ProtocolM s (WireDown s i)) diff --git a/src/Quasar/Wayland/Protocol/TH.hs b/src/Quasar/Wayland/Protocol/TH.hs index 8388a246adc5dd366d5591e18906010cedd6eb46..e6d76183f6d91c2365c101e5efd2ed441e816e08 100644 --- a/src/Quasar/Wayland/Protocol/TH.hs +++ b/src/Quasar/Wayland/Protocol/TH.hs @@ -108,13 +108,15 @@ interfaceDecs interface = do iName = interfaceN interface iT = interfaceT interface instanceDecs = [ - tySynInstD (tySynEqn Nothing (appT (conT ''WireRequest) iT) rT), + tySynInstD (tySynEqn Nothing (appT (conT ''Requests) iT) (requestsT interface)), + tySynInstD (tySynEqn Nothing (appT (conT ''Events) iT) (eventsT interface)), + tySynInstD (tySynEqn Nothing (appT (conT ''WireRequest) iT) wireRequestT), tySynInstD (tySynEqn Nothing (appT (conT ''WireEvent) iT) eT), tySynInstD (tySynEqn Nothing (appT (conT ''InterfaceName) iT) (litT (strTyLit interface.name))), valD (varP 'interfaceName) (normalB (stringE interface.name)) [] ] - rT :: Q Type - rT = if length interface.requests > 0 then conT rTypeName else [t|Void|] + wireRequestT :: Q Type + wireRequestT = if length interface.requests > 0 then conT rTypeName else [t|Void|] rTypeName :: Name rTypeName = mkName $ "WireRequest_" <> interface.name rConName :: RequestSpec -> Name @@ -128,7 +130,7 @@ interfaceDecs interface = do requestContext :: RequestSpec -> MessageContext requestContext req@(RequestSpec msgSpec) = MessageContext { msgInterfaceT = iT, - msgT = rT, + msgT = wireRequestT, msgConName = rConName req, msgInterfaceSpec = interface, msgSpec = msgSpec @@ -145,10 +147,10 @@ interfaceDecs interface = do eventContexts = eventContext <$> interface.events requestRecordD :: Q Dec - requestRecordD = messageRecordD (requestClassN interface) requestContexts + requestRecordD = messageRecordD (requestsName interface) requestContexts eventRecordD :: Q Dec - eventRecordD = messageRecordD (eventClassN interface) eventContexts + eventRecordD = messageRecordD (eventsName interface) eventContexts messageRecordD :: Name -> [MessageContext] -> Q Dec messageRecordD name messageContexts = dataD (cxt []) name [] Nothing [con] [] @@ -177,17 +179,17 @@ interfaceN interface = mkName $ "Interface_" <> interface.name interfaceT :: InterfaceSpec -> Q Type interfaceT interface = conT (interfaceN interface) -requestClassN :: InterfaceSpec -> Name -requestClassN interface = mkName $ "Requests_" <> interface.name +requestsName :: InterfaceSpec -> Name +requestsName interface = mkName $ "Requests_" <> interface.name -requestClassT :: InterfaceSpec -> Q Type -requestClassT interface = conT (requestClassN interface) +requestsT :: InterfaceSpec -> Q Type +requestsT interface = conT (requestsName interface) -eventClassN :: InterfaceSpec -> Name -eventClassN interface = mkName $ "Events_" <> interface.name +eventsName :: InterfaceSpec -> Name +eventsName interface = mkName $ "Events_" <> interface.name -eventClassT :: InterfaceSpec -> Q Type -eventClassT interface = conT (eventClassN interface) +eventsT :: InterfaceSpec -> Q Type +eventsT interface = conT (eventsName interface)