Pretty-print messages

src/Quasar/Wayland/Client.hs

@@ -36,7 +36,7 @@ newWaylandClient socket = WaylandClient <$> newWaylandConnection @I_wl_display @
 clientCallback :: IsInterfaceSide 'Client i => ClientCallback STM i
 clientCallback = Callback {
   messageCallback = \object message ->
-    lift $ traceM $ objectInterfaceName object <> "@" <> show (objectId object) <> "." <> showMessage message
+    lift $ traceM $ showObjectMessage object message
 }
 
 connectWaylandClient :: MonadResourceManager m => m WaylandClient

src/Quasar/Wayland/Protocol/Core.hs

@@ -25,7 +25,9 @@ module Quasar.Wayland.Protocol.Core (
   feedInput,
   setException,
 
-  -- Message decoder operations
+  showObjectMessage,
+
+  -- * Message decoder operations
   WireFormat(..),
   dropRemaining,
 ) where
@@ -239,13 +241,11 @@ instance IsObjectSide (SomeObject s m) where
 
 class (Eq a, Show a) => IsMessage a where
   opcodeName :: Opcode -> Maybe String
-  showMessage :: IsMessage a => a -> String
   getMessage :: IsInterface i => Object s m i -> Opcode -> Get a
   putMessage :: a -> PutM ()
 
 instance IsMessage Void where
   opcodeName _ = Nothing
-  showMessage = absurd
   getMessage = invalidOpcode
   putMessage = absurd
 
@@ -253,6 +253,10 @@ invalidOpcode :: IsInterface i => Object s m i -> Opcode -> Get a
 invalidOpcode object opcode =
   fail $ "Invalid opcode " <> show opcode <> " on " <> objectInterfaceName object <> "@" <> show (objectId object)
 
+showObjectMessage :: (IsObject a, IsMessage b) => a -> b -> String
+showObjectMessage object message =
+  objectInterfaceName object <> "@" <> show (objectId object) <> "." <> show message
+
 
 -- TODO remove
 data DynamicArgument
@@ -402,9 +406,7 @@ handleMessage rawMessage@(oId, opcode, body) = do
   case HM.lookup oId st.objects of
     Nothing -> throwM $ ProtocolException $ "Received message with invalid object id " <> show oId
 
-    Just (SomeObject object) -> do
-      traceM $ "Received message (raw) " <> describeDownMessage object opcode body
-
+    Just (SomeObject object) ->
       case runGetOrFail (getMessageAction st.objects object rawMessage) body of
         Left (_, _, message) ->
           throwM $ ParserFailed (describeDownMessage object opcode body) message
@@ -413,7 +415,7 @@ handleMessage rawMessage@(oId, opcode, body) = do
           throwM $ ParserFailed (describeDownMessage object opcode body) (show (BSL.length leftovers) <> "B not parsed")
 
     Just (UnknownObject interface oId) -> do
-      throwM $ ProtocolException $ "Received message for unknown object " <> interface <> "@" <> show oId
+      throwM $ ProtocolException $ "Received message for object without handler: " <> interface <> "@" <> show oId
 
 getMessageAction
   :: (IsSide s, IsInterface i, MonadCatch m)
@@ -423,7 +425,7 @@ getMessageAction
   -> Get (ProtocolAction s m ())
 getMessageAction objects object@(Object _ callback) (oId, opcode, body) = do
   message <- getDown object opcode
-  pure $ traceM $ "Received message " <> show message
+  pure $ traceM $ "<- " <> showObjectMessage object message
 
 type ProtocolAction s m a = StateT (ProtocolState s m) m a
 

src/Quasar/Wayland/Protocol/TH.hs

@@ -9,6 +9,7 @@ import Language.Haskell.TH
 import Language.Haskell.TH.Lib
 import Language.Haskell.TH.Syntax (BangType, VarBangType, addDependentFile)
 import Language.Haskell.TH.Syntax qualified as TH
+import Data.List (intersperse)
 import Quasar.Prelude
 import Quasar.Wayland.Protocol.Core
 import Text.XML.Light
@@ -129,32 +130,50 @@ data MessageContext = MessageContext {
   msgArgFieldName :: ArgumentSpec -> Name
 }
 
+-- | Pattern to match a message. Arguments can then be accessed by using 'msgArgE'.
+msgConP :: MessageContext -> Q Pat
+msgConP msg = conP msg.msgConName (varP . (msg.msgArgFieldName) <$> msg.msgSpec.arguments)
+
+-- | Expression for accessing a message argument which has been matched from a request/event using 'msgArgConP'.
+msgArgE :: MessageContext -> ArgumentSpec -> Q Exp
+msgArgE msg arg = varE (msg.msgArgFieldName arg)
+
 messageTypeDecs :: Name -> [MessageContext] -> Q [Dec]
 messageTypeDecs name msgs = execWriterT do
   tellQ $ messageTypeD
   tellQ $ isMessageInstanceD t msgs
+  tellQ $ showInstanceD
   where
     t :: Q Type
     t = conT name
     messageTypeD :: Q Dec
-    messageTypeD = dataD (pure []) name [] Nothing (con <$> msgs) [derivingEq, derivingShow]
+    messageTypeD = dataD (pure []) name [] Nothing (con <$> msgs) [derivingEq]
     con :: MessageContext -> Q Con
     con msg = recC (msg.msgConName) (conField <$> msg.msgSpec.arguments)
       where
         conField :: ArgumentSpec -> Q VarBangType
         conField arg = defaultVarBangType (msg.msgArgFieldName arg) (argumentType arg)
+    showInstanceD :: Q Dec
+    showInstanceD = instanceD (pure []) [t|Show $t|] [showD]
+    showD :: Q Dec
+    showD = funD 'show (showClause <$> msgs)
+    showClause :: MessageContext -> Q Clause
+    showClause msg =
+      clause
+        [msgConP msg]
+        (normalB [|mconcat $(listE ([stringE (msg.msgSpec.name ++ "(")] <> mconcat (intersperse [stringE ", "] (showArgE <$> msg.msgSpec.arguments) <> [[stringE ")"]])))|])
+        []
+      where
+        showArgE :: ArgumentSpec -> [Q Exp]
+        showArgE arg = [stringE (arg.name ++ "="), [|showArgument @($(argumentSpecType arg)) $(msgArgE msg arg)|]]
 
 isMessageInstanceD :: Q Type -> [MessageContext] -> Q Dec
-isMessageInstanceD t msgs = instanceD (pure []) [t|IsMessage $t|] [opcodeNameD, showMessageD, getMessageD, putMessageD]
+isMessageInstanceD t msgs = instanceD (pure []) [t|IsMessage $t|] [opcodeNameD, getMessageD, putMessageD]
   where
     opcodeNameD :: Q Dec
     opcodeNameD = funD 'opcodeName (opcodeNameClauseD <$> msgs)
     opcodeNameClauseD :: MessageContext -> Q Clause
     opcodeNameClauseD msg = clause [litP (integerL (fromIntegral msg.msgSpec.opcode))] (normalB ([|Just $(stringE msg.msgSpec.name)|])) []
-    showMessageD :: Q Dec
-    showMessageD = funD 'showMessage (showMessageClauseD <$> msgs)
-    showMessageClauseD :: MessageContext -> Q Clause
-    showMessageClauseD msg = clause [conP msg.msgConName (replicate (length msg.msgSpec.arguments) wildP)] (normalB (stringE msg.msgSpec.name)) []
     getMessageD :: Q Dec
     getMessageD = funD 'getMessage (getMessageClauseD <$> msgs)
     getMessageClauseD :: MessageContext -> Q Clause