diff --git a/src/Quasar/Wayland/Protocol/Core.hs b/src/Quasar/Wayland/Protocol/Core.hs index 3ab177560980a27197fd1541b13ba493280054c6..4d75ebe415a5c59b2351e794353f295a1684bcb9 100644 --- a/src/Quasar/Wayland/Protocol/Core.hs +++ b/src/Quasar/Wayland/Protocol/Core.hs @@ -403,7 +403,7 @@ setException ex = protocolStep do State.modify \st -> st{protocolException = Just (toException ex)} --- Create an object. The caller is responsible for sending the 'NewId' exactly once before using the object. +-- | Create an object. The caller is responsible for sending the 'NewId' exactly once before using the object. newObject :: forall s m i. (IsInterfaceSide s i, MonadCatch m) => Callback s m i @@ -415,14 +415,12 @@ newObjectInternal => Callback s m i -> ProtocolAction s m (Object s m i, NewId (InterfaceName i)) newObjectInternal callback = do - oId <- allocateObjectId @s @m @i - let - object = Object oId callback - someObject = SomeObject object - State.modify \st -> st { objects = HM.insert oId someObject st.objects} - pure (object, NewId oId) + genOId <- allocateObjectId @s @m + let oId = NewId @(InterfaceName i) genOId + object <- newObjectFromId oId callback + pure (object, oId) where - allocateObjectId :: forall s m i. (IsInterfaceSide s i, MonadCatch m) => ProtocolAction s m GenericObjectId + allocateObjectId :: forall s m. (IsSide s, MonadCatch m) => ProtocolAction s m GenericObjectId allocateObjectId = do st <- State.get let @@ -433,6 +431,18 @@ newObjectInternal callback = do State.put $ st {nextId = nextId'} pure id +newObjectFromId + :: forall s m i. (IsInterfaceSide s i, MonadCatch m) + => NewId (InterfaceName i) + -> Callback s m i + -> ProtocolAction s m (Object s m i) +newObjectFromId (NewId oId) callback = do + let + object = Object oId callback + someObject = SomeObject object + State.modify \st -> st { objects = HM.insert oId someObject st.objects} + pure object + -- | Sends a message without checking any ids or creating proxy objects objects. sendMessage :: forall s m i. (IsInterfaceSide s i, MonadCatch m) => Object s m i -> Up s i -> ProtocolStep s m ()