diff --git a/quasar-wayland.cabal b/quasar-wayland.cabal index 01317193a0b037454aa03c87be2f72698e7de198..027da6714da4a0f0a9772415fd1601cf3dddba1c 100644 --- a/quasar-wayland.cabal +++ b/quasar-wayland.cabal @@ -77,9 +77,9 @@ library Quasar.Wayland.Client Quasar.Wayland.Client.Registry Quasar.Wayland.Client.Socket + Quasar.Wayland.Client.Sync Quasar.Wayland.Connection Quasar.Wayland.Protocol - Quasar.Wayland.Protocol.Display Quasar.Wayland.Protocol.Generated Quasar.Wayland.Protocol.TH other-modules: diff --git a/src/Quasar/Wayland/Client.hs b/src/Quasar/Wayland/Client.hs index ee2b9f0e6ea74a6bf25dd877bca9aacbcd5e5d50..848a9852bae48a862a0376880f7267df4d9dbf0e 100644 --- a/src/Quasar/Wayland/Client.hs +++ b/src/Quasar/Wayland/Client.hs @@ -13,11 +13,11 @@ import GHC.Records import Network.Socket (Socket) import Quasar import Quasar.Prelude +import Quasar.Wayland.Client.Sync import Quasar.Wayland.Client.Registry import Quasar.Wayland.Client.Socket import Quasar.Wayland.Connection import Quasar.Wayland.Protocol -import Quasar.Wayland.Protocol.Display import Quasar.Wayland.Protocol.Generated @@ -48,10 +48,19 @@ newWaylandClient socket = do } where newClientDisplay :: STM ((Object 'Client Interface_wl_display, Registry), ProtocolHandle 'Client) - newClientDisplay = - initializeProtocol wlDisplayEventHandler \wlDisplay -> do - registry <- createRegistry wlDisplay - pure (wlDisplay, registry) + newClientDisplay = initializeProtocol wlDisplayEventHandler init + + init :: Object 'Client Interface_wl_display -> STM (Object 'Client Interface_wl_display, Registry) + init wlDisplay = do + registry <- createRegistry wlDisplay + pure (wlDisplay, registry) + + wlDisplayEventHandler :: ProtocolHandle 'Client -> EventHandler_wl_display + wlDisplayEventHandler protocol = + EventHandler_wl_display { + error = handleWlDisplayError protocol, + delete_id = handleWlDisplayDeleteId protocol + } diff --git a/src/Quasar/Wayland/Client/Registry.hs b/src/Quasar/Wayland/Client/Registry.hs index 26ee1e6d63f00a1c72ae91f25af4501ae64f3786..138a46e79fe693988c2208605fd74e962228faf2 100644 --- a/src/Quasar/Wayland/Client/Registry.hs +++ b/src/Quasar/Wayland/Client/Registry.hs @@ -8,8 +8,8 @@ import Data.HashMap.Strict qualified as HM import Data.Tuple (swap) import Quasar import Quasar.Prelude +import Quasar.Wayland.Client.Sync import Quasar.Wayland.Protocol -import Quasar.Wayland.Protocol.Display import Quasar.Wayland.Protocol.Generated -- * wl_registry diff --git a/src/Quasar/Wayland/Client/Sync.hs b/src/Quasar/Wayland/Client/Sync.hs new file mode 100644 index 0000000000000000000000000000000000000000..06fdf5f718077153a81d264fbdbbea597d69255b --- /dev/null +++ b/src/Quasar/Wayland/Client/Sync.hs @@ -0,0 +1,15 @@ +module Quasar.Wayland.Client.Sync ( + lowLevelSync, +) where + +import Control.Monad.STM +import Quasar.Prelude +import Quasar.Wayland.Protocol +import Quasar.Wayland.Protocol.Generated + +lowLevelSync :: Object 'Client Interface_wl_display -> (Word32 -> STM ()) -> STM () +lowLevelSync wlDisplay callback = do + wlCallback <- wlDisplay.sync + setEventHandler wlCallback EventHandler_wl_callback { + done = callback + } diff --git a/src/Quasar/Wayland/Protocol.hs b/src/Quasar/Wayland/Protocol.hs index 68e59f5556e9b4aaae92014dcd8f843315e6ef6b..c3f9e7394a1996b1929bfeb1711dc2c1fdddb220 100644 --- a/src/Quasar/Wayland/Protocol.hs +++ b/src/Quasar/Wayland/Protocol.hs @@ -32,6 +32,10 @@ module Quasar.Wayland.Protocol ( interfaceName, Side(..), IsSide, + + -- * wl_display interface + handleWlDisplayError, + handleWlDisplayDeleteId, ) where import Quasar.Wayland.Protocol.Core diff --git a/src/Quasar/Wayland/Protocol/Core.hs b/src/Quasar/Wayland/Protocol/Core.hs index 2650d89e03a4d6d2c906643c1a577201b901754b..0205a202a7f382b07810e26d7e19646c1717c604 100644 --- a/src/Quasar/Wayland/Protocol/Core.hs +++ b/src/Quasar/Wayland/Protocol/Core.hs @@ -43,6 +43,10 @@ module Quasar.Wayland.Protocol.Core ( getObject, lookupObject, + -- * wl_display interface + handleWlDisplayError, + handleWlDisplayDeleteId, + -- * Protocol exceptions WireCallbackFailed(..), ParserFailed(..), @@ -420,7 +424,7 @@ stateProtocolVar fn x = do initializeProtocol :: forall s wl_display a. (IsInterfaceSide s wl_display) - => MessageHandler s wl_display + => (ProtocolHandle s -> MessageHandler s wl_display) -> (Object s wl_display -> STM a) -> STM (a, ProtocolHandle s) initializeProtocol wlDisplayMessageHandler initializationAction = do @@ -451,7 +455,7 @@ initializeProtocol wlDisplayMessageHandler initializationAction = do } writeTVar stateVar (Right state) - messageHandlerVar <- newTVar (Just wlDisplayMessageHandler) + messageHandlerVar <- newTVar (Just (wlDisplayMessageHandler protocol)) let wlDisplay = Object protocol wlDisplayId messageHandlerVar modifyTVar' objectsVar (HM.insert (toGenericObjectId wlDisplayId) (SomeObject wlDisplay)) @@ -592,6 +596,20 @@ getObject oId = either (throwM . InvalidObject) pure =<< lookupObject oId +-- | Handle a wl_display.error message. Because this is part of the core protocol but generated from the xml it has to +-- be called from the client module. +handleWlDisplayError :: ProtocolHandle 'Client -> GenericObjectId -> Word32 -> WlString -> STM () +handleWlDisplayError _protocol oId code message = throwM $ ServerError code (toString message) + +-- | Handle a wl_display.delete_id message. Because this is part of the core protocol but generated from the xml it has +-- to be called from the client module. +handleWlDisplayDeleteId :: ProtocolHandle 'Client -> Word32 -> STM () +handleWlDisplayDeleteId protocol oId = runProtocolM protocol do + modifyProtocolVar (.objectsVar) $ HM.delete (GenericObjectId oId) + traceM $ mconcat ["Deleted object id ", show oId] + + + -- | Sends a message without checking any ids or creating proxy objects objects. (TODO) sendMessage :: forall s i. IsInterfaceSide s i => Object s i -> WireUp s i -> ProtocolM s () sendMessage object message = do diff --git a/src/Quasar/Wayland/Protocol/Display.hs b/src/Quasar/Wayland/Protocol/Display.hs deleted file mode 100644 index c37e3e1d663afc820e9ded0e7a1b312c53b2d8fd..0000000000000000000000000000000000000000 --- a/src/Quasar/Wayland/Protocol/Display.hs +++ /dev/null @@ -1,30 +0,0 @@ -module Quasar.Wayland.Protocol.Display ( - lowLevelSync, - wlDisplayEventHandler, -) where - -import Control.Monad.Catch -import Control.Monad.STM -import Quasar.Prelude -import Quasar.Wayland.Protocol.Core -import Quasar.Wayland.Protocol.Generated - - - --- | Default implementation for @wl_display@ that handles errors and confirms deleted object ids. --- --- This is only required when manually managing the @wl_display@ interface (usually it's applied by --- 'Quasar.Wayland.Display.newClientDisplay'). -wlDisplayEventHandler :: EventHandler_wl_display -wlDisplayEventHandler = EventHandler_wl_display { error = waylandError, delete_id } - where - waylandError oId code message = throwM $ ServerError code (toString message) - delete_id deletedId = pure () -- TODO confirm delete - - -lowLevelSync :: Object 'Client Interface_wl_display -> (Word32 -> STM ()) -> STM () -lowLevelSync wlDisplay callback = do - wlCallback <- wlDisplay.sync - setEventHandler wlCallback EventHandler_wl_callback { - done = callback - }