From fa7c8a6692ffa9dda4f6462129ef20756e6e8993 Mon Sep 17 00:00:00 2001
From: Jens Nolte <git@queezle.net>
Date: Tue, 7 Dec 2021 14:50:39 +0100
Subject: [PATCH] Move tracing back into protocol core
---
src/Quasar/Wayland/Protocol/Core.hs | 10 ++++++----
src/Quasar/Wayland/Registry.hs | 2 +-
2 files changed, 7 insertions(+), 5 deletions(-)
diff --git a/src/Quasar/Wayland/Protocol/Core.hs b/src/Quasar/Wayland/Protocol/Core.hs
index 1b65d45..8668bee 100644
--- a/src/Quasar/Wayland/Protocol/Core.hs
+++ b/src/Quasar/Wayland/Protocol/Core.hs
@@ -225,7 +225,6 @@ instance IsSide 'Server where
maximumId = 0xffffffff
---- | Empty class, used to combine constraints
class (
IsSide s,
IsInterface i,
@@ -506,9 +505,9 @@ runProtocolTransaction (protocol@ProtocolHandle{stateVar}) action = do
-- | Run a 'ProtocolM'-action inside 'STM'.
--
--- Exceptions are not handled and reset the transaction (as usual with STM).
---
-- Throws an exception, if the protocol is already in a failed state.
+--
+-- Exceptions are not handled (i.e. they usually reset the STM transaction and are not stored as a protocol failure).
runProtocolM :: ProtocolHandle s -> ProtocolM s a -> STM a
runProtocolM protocol action = either throwM (runReaderT action) =<< readTVar protocol.stateVar
@@ -635,7 +634,10 @@ getMessageAction
-> Get (ProtocolM s ())
getMessageAction object@(Object _ _ _ _ objectHandler) opcode = do
verifyMessage <- getWireDown object opcode
- pure $ handlerHandleMessage objectHandler object =<< verifyMessage
+ pure do
+ message <- verifyMessage
+ traceM $ "<- " <> showObjectMessage object message
+ handlerHandleMessage objectHandler object message
type RawMessage = (GenericObjectId, Opcode, BSL.ByteString)
diff --git a/src/Quasar/Wayland/Registry.hs b/src/Quasar/Wayland/Registry.hs
index bb6ea7c..815f808 100644
--- a/src/Quasar/Wayland/Registry.hs
+++ b/src/Quasar/Wayland/Registry.hs
@@ -22,7 +22,7 @@ createClientRegistry :: Object 'Client Interface_wl_display -> ProtocolM 'Client
createClientRegistry wlDisplay = mfix \clientRegistry -> do
globalsVar <- lift $ newTVar HM.empty
- (wlRegistry, newId) <- newObject @'Client @Interface_wl_registry (traceWireCallback (callback clientRegistry))
+ (wlRegistry, newId) <- newObject @'Client @Interface_wl_registry (callback clientRegistry)
sendMessage wlDisplay $ WireRequest_wl_display_get_registry newId
pure ClientRegistry {
--
GitLab