From 37f47de4191e9eee62b7b9507b0e68b49a080cd9 Mon Sep 17 00:00:00 2001
From: Jens Nolte <git@queezle.net>
Date: Tue, 21 Sep 2021 19:06:28 +0200
Subject: [PATCH] Prefix low-level message types with 'Wire'

---
 src/Quasar/Wayland/Display.hs          |  2 +-
 src/Quasar/Wayland/Protocol.hs         | 12 ++--
 src/Quasar/Wayland/Protocol/Core.hs    | 96 +++++++++++++-------------
 src/Quasar/Wayland/Protocol/Display.hs |  6 +-
 src/Quasar/Wayland/Protocol/TH.hs      | 20 +++---
 src/Quasar/Wayland/Registry.hs         |  6 +-
 6 files changed, 71 insertions(+), 71 deletions(-)

diff --git a/src/Quasar/Wayland/Display.hs b/src/Quasar/Wayland/Display.hs
index 4ccf4c3..36af738 100644
--- a/src/Quasar/Wayland/Display.hs
+++ b/src/Quasar/Wayland/Display.hs
@@ -19,7 +19,7 @@ newClientDisplay
   :: (IsInterfaceSide 'Client Interface_wl_display)
   => STM (ClientDisplay, ProtocolHandle 'Client)
 newClientDisplay =
-  initializeProtocol clientWlDisplayCallback \wlDisplay -> do
+  initializeProtocol clientWlDisplayWireCallback \wlDisplay -> do
     registry <- createClientRegistry wlDisplay
     pure ClientDisplay {
       wlDisplay,
diff --git a/src/Quasar/Wayland/Protocol.hs b/src/Quasar/Wayland/Protocol.hs
index ac0cf01..97db046 100644
--- a/src/Quasar/Wayland/Protocol.hs
+++ b/src/Quasar/Wayland/Protocol.hs
@@ -11,9 +11,9 @@ module Quasar.Wayland.Protocol (
   WlString(..),
 
   -- ** Classes for generated interfaces
-  IsInterface(Request, Event, InterfaceName, interfaceName),
+  IsInterface(WireRequest, WireEvent, InterfaceName, interfaceName),
   Side(..),
-  IsSide(Up, Down),
+  IsSide(WireUp, WireDown),
   IsInterfaceSide,
 
   -- ** Protocol execution
@@ -31,13 +31,13 @@ module Quasar.Wayland.Protocol (
   newObject,
   sendMessage,
 
-  Callback(..),
-  internalFnCallback,
-  traceCallback,
+  WireCallback(..),
+  internalFnWireCallback,
+  traceWireCallback,
   ignoreMessage,
 
   -- * Protocol exceptions
-  CallbackFailed(..),
+  WireCallbackFailed(..),
   ParserFailed(..),
   ProtocolException(..),
   MaximumIdReached(..),
diff --git a/src/Quasar/Wayland/Protocol/Core.hs b/src/Quasar/Wayland/Protocol/Core.hs
index 0fa8c2d..21f15b6 100644
--- a/src/Quasar/Wayland/Protocol/Core.hs
+++ b/src/Quasar/Wayland/Protocol/Core.hs
@@ -33,14 +33,14 @@ module Quasar.Wayland.Protocol.Core (
   sendMessage,
   newObject,
 
-  -- ** Callbacks
-  Callback(..),
-  internalFnCallback,
-  traceCallback,
+  -- ** WireCallbacks
+  WireCallback(..),
+  internalFnWireCallback,
+  traceWireCallback,
   ignoreMessage,
 
   -- * Protocol exceptions
-  CallbackFailed(..),
+  WireCallbackFailed(..),
   ParserFailed(..),
   ProtocolException(..),
   MaximumIdReached(..),
@@ -179,31 +179,31 @@ instance WireFormat Void where
 
 -- | Class for a proxy type (in the haskell sense) that describes a Wayland interface.
 class (
-    IsMessage (Request i),
-    IsMessage (Event i)
+    IsMessage (WireRequest i),
+    IsMessage (WireEvent i)
   )
   => IsInterface i where
-  type Request i
-  type Event i
+  type WireRequest i
+  type WireEvent i
   type InterfaceName i :: Symbol
   interfaceName :: String
 
 class IsSide (s :: Side) where
-  type Up s i
-  type Down s i
+  type WireUp s i
+  type WireDown s i
   initialId :: Word32
   maximumId :: Word32
 
 instance IsSide 'Client where
-  type Up 'Client i = Request i
-  type Down 'Client i = Event i
+  type WireUp 'Client i = WireRequest i
+  type WireDown 'Client i = WireEvent i
   -- Id #1 is reserved for wl_display
   initialId = 2
   maximumId = 0xfeffffff
 
 instance IsSide 'Server where
-  type Up 'Server i = Event i
-  type Down 'Server i = Request i
+  type WireUp 'Server i = WireEvent i
+  type WireDown 'Server i = WireRequest i
   initialId = 0xff000000
   maximumId = 0xffffffff
 
@@ -212,27 +212,27 @@ instance IsSide 'Server where
 class (
     IsSide s,
     IsInterface i,
-    IsMessage (Up s i),
-    IsMessage (Down s i)
+    IsMessage (WireUp s i),
+    IsMessage (WireDown s i)
   )
   => IsInterfaceSide (s :: Side) i
 
 
-getDown :: forall s i. IsInterfaceSide s i => Object s i -> Opcode -> Get (ProtocolM s (Down s i))
-getDown = getMessage @(Down s i)
+getWireDown :: forall s i. IsInterfaceSide s i => Object s i -> Opcode -> Get (ProtocolM s (WireDown s i))
+getWireDown = getMessage @(WireDown s i)
 
-putUp :: forall s i. IsInterfaceSide s i => Object s i -> Up s i -> ProtocolM s (Opcode, [(Put, Int)])
-putUp _ = putMessage @(Up s i)
+putWireUp :: forall s i. IsInterfaceSide s i => Object s i -> WireUp s i -> ProtocolM s (Opcode, [(Put, Int)])
+putWireUp _ = putMessage @(WireUp s i)
 
 
 class IsInterfaceSide s i => IsInterfaceHandler s i a where
-  handleMessage :: a -> Object s i -> Down s i -> ProtocolM s ()
+  handleMessage :: a -> Object s i -> WireDown s i -> ProtocolM s ()
 
 
 -- | Data kind
 data Side = Client | Server
 
-data Object s i = IsInterfaceSide s i => Object GenericObjectId (Callback s i)
+data Object s i = IsInterfaceSide s i => Object GenericObjectId (WireCallback s i)
 
 instance IsInterface i => Show (Object s i) where
   show = showObject
@@ -254,11 +254,11 @@ instance forall s i. IsInterface i => IsObject (Object s i) where
 instance forall s i. IsInterfaceSide s i => IsObjectSide (Object s i) where
   describeUpMessage object opcode body =
     objectInterfaceName object <> "@" <> show (objectId object) <>
-    "." <> fromMaybe "[invalidOpcode]" (opcodeName @(Up s i) opcode) <>
+    "." <> fromMaybe "[invalidOpcode]" (opcodeName @(WireUp s i) opcode) <>
     " (" <> show (BSL.length body) <> "B)"
   describeDownMessage object opcode body =
     objectInterfaceName object <> "@" <> show (objectId object) <>
-    "." <> fromMaybe "[invalidOpcode]" (opcodeName @(Down s i) opcode) <>
+    "." <> fromMaybe "[invalidOpcode]" (opcodeName @(WireDown s i) opcode) <>
     " (" <> show (BSL.length body) <> "B)"
 
 -- | Wayland object quantification wrapper
@@ -302,22 +302,22 @@ showObjectMessage object message =
   showObject object <> "." <> show message
 
 
-data Callback s i = forall a. IsInterfaceHandler s i a => Callback a
+data WireCallback s i = forall a. IsInterfaceHandler s i a => WireCallback a
 
-instance IsInterfaceSide s i => IsInterfaceHandler s i (Callback s i) where
-  handleMessage (Callback callback) = handleMessage callback
+instance IsInterfaceSide s i => IsInterfaceHandler s i (WireCallback s i) where
+  handleMessage (WireCallback callback) = handleMessage callback
 
 
-data LowLevelCallback s i = IsInterfaceSide s i => FnCallback (Object s i -> Down s i -> ProtocolM s ())
+data LowLevelWireCallback s i = IsInterfaceSide s i => FnWireCallback (Object s i -> WireDown s i -> ProtocolM s ())
 
-instance IsInterfaceSide s i => IsInterfaceHandler s i (LowLevelCallback s i) where
-  handleMessage (FnCallback fn) object msg = fn object msg
+instance IsInterfaceSide s i => IsInterfaceHandler s i (LowLevelWireCallback s i) where
+  handleMessage (FnWireCallback fn) object msg = fn object msg
 
-internalFnCallback :: IsInterfaceSide s i => (Object s i -> Down s i -> ProtocolM s ()) -> Callback s i
-internalFnCallback = Callback . FnCallback
+internalFnWireCallback :: IsInterfaceSide s i => (Object s i -> WireDown s i -> ProtocolM s ()) -> WireCallback s i
+internalFnWireCallback = WireCallback . FnWireCallback
 
 
--- | The 'traceCallback' callback outputs a trace for every received message, before passing the message to the callback
+-- | The 'traceWireCallback' callback outputs a trace for every received message, before passing the message to the callback
 -- argument.
 --
 -- The 'trace' function should /only/ be used for debugging, or for monitoring execution. The function is not
@@ -325,18 +325,18 @@ internalFnCallback = Callback . FnCallback
 -- trace message.
 --
 -- Uses `traceM` internally.
-traceCallback :: IsInterfaceSide 'Client i => Callback 'Client i -> Callback 'Client i
-traceCallback next = internalFnCallback \object message -> do
+traceWireCallback :: IsInterfaceSide 'Client i => WireCallback 'Client i -> WireCallback 'Client i
+traceWireCallback next = internalFnWireCallback \object message -> do
   traceM $ "<- " <> showObjectMessage object message
   handleMessage next object message
 
--- | A `Callback` that ignores all messages. Intended for development purposes, e.g. together with `traceCallback`.
-ignoreMessage :: IsInterfaceSide 'Client i => Callback 'Client i
-ignoreMessage = internalFnCallback \_ _ -> pure ()
+-- | A `WireCallback` that ignores all messages. Intended for development purposes, e.g. together with `traceWireCallback`.
+ignoreMessage :: IsInterfaceSide 'Client i => WireCallback 'Client i
+ignoreMessage = internalFnWireCallback \_ _ -> pure ()
 
 -- * Exceptions
 
-data CallbackFailed = CallbackFailed SomeException
+data WireCallbackFailed = WireCallbackFailed SomeException
   deriving stock Show
   deriving anyclass Exception
 
@@ -406,10 +406,10 @@ stateProtocolVar fn x = do
 
 initializeProtocol
   :: forall s wl_display a. (IsInterfaceSide s wl_display)
-  => Callback s wl_display
+  => WireCallback s wl_display
   -> (Object s wl_display -> ProtocolM s a)
   -> STM (a, ProtocolHandle s)
-initializeProtocol wlDisplayCallback initializationAction = do
+initializeProtocol wlDisplayWireCallback initializationAction = do
   bytesReceivedVar <- newTVar 0
   bytesSentVar <- newTVar 0
   inboxDecoderVar <- newTVar $ runGetIncremental getRawMessage
@@ -434,7 +434,7 @@ initializeProtocol wlDisplayCallback initializationAction = do
     wlDisplayId :: GenericObjectId
     wlDisplayId = GenericObjectId 1
     wlDisplay :: Object s wl_display
-    wlDisplay = Object wlDisplayId wlDisplayCallback
+    wlDisplay = Object wlDisplayId wlDisplayWireCallback
 
 -- | Run a protocol action in 'IO'. If an exception occurs, it is stored as a protocol failure and is then
 -- re-thrown.
@@ -494,7 +494,7 @@ takeOutbox protocol = runProtocolTransaction protocol do
 -- transaction; before using the object).
 newObject
   :: forall s i. IsInterfaceSide s i
-  => Callback s i
+  => WireCallback s i
   -> ProtocolM s (Object s i, NewId (InterfaceName i))
 newObject callback = do
   oId <- allocateObjectId
@@ -515,7 +515,7 @@ newObject callback = do
 newObjectFromId
   :: forall s i. IsInterfaceSide s i
   => NewId (InterfaceName i)
-  -> Callback s i
+  -> WireCallback s i
   -> ProtocolM s (Object s i)
 newObjectFromId (NewId oId) callback = do
   let
@@ -527,12 +527,12 @@ newObjectFromId (NewId oId) callback = do
 
 
 -- | Sends a message without checking any ids or creating proxy objects objects. (TODO)
-sendMessage :: forall s i. IsInterfaceSide s i => Object s i -> Up s i -> ProtocolM s ()
+sendMessage :: forall s i. IsInterfaceSide s i => Object s i -> WireUp s i -> ProtocolM s ()
 sendMessage object message = do
   isActiveObject <- HM.member oId <$> readProtocolVar (.objectsVar)
   unless isActiveObject $ throwM $ ProtocolUsageError $ "Tried to send message on an invalid object: " <> show object
 
-  (opcode, pairs) <- putUp object message
+  (opcode, pairs) <- putWireUp object message
   let (putBodyParts, partLengths) = unzip pairs
   let putBody = mconcat putBodyParts
 
@@ -581,7 +581,7 @@ getMessageAction
   -> Opcode
   -> Get (ProtocolM s ())
 getMessageAction object@(Object _ objectHandler) opcode = do
-  verifyMessage <- getDown object opcode
+  verifyMessage <- getWireDown object opcode
   pure $ handleMessage objectHandler object =<< verifyMessage
 
 type RawMessage = (GenericObjectId, Opcode, BSL.ByteString)
diff --git a/src/Quasar/Wayland/Protocol/Display.hs b/src/Quasar/Wayland/Protocol/Display.hs
index 46e99fb..bc3c04c 100644
--- a/src/Quasar/Wayland/Protocol/Display.hs
+++ b/src/Quasar/Wayland/Protocol/Display.hs
@@ -1,5 +1,5 @@
 module Quasar.Wayland.Protocol.Display (
-  clientWlDisplayCallback,
+  clientWlDisplayWireCallback,
 ) where
 
 import Control.Monad.Catch
@@ -12,8 +12,8 @@ import Quasar.Wayland.Protocol.Generated
 --
 -- This is only required when manually managing the @wl_display@ interface (usually it's applied by
 -- 'Quasar.Wayland.Display.newClientDisplay').
-clientWlDisplayCallback :: IsInterfaceSide 'Client Interface_wl_display => Callback 'Client Interface_wl_display
-clientWlDisplayCallback = internalFnCallback handler
+clientWlDisplayWireCallback :: IsInterfaceSide 'Client Interface_wl_display => WireCallback 'Client Interface_wl_display
+clientWlDisplayWireCallback = internalFnWireCallback handler
   where
     -- | wl_display is specified to never change, so manually specifying the callback is safe
     handler :: Object 'Client Interface_wl_display -> WireEvent_wl_display -> ProtocolM 'Client ()
diff --git a/src/Quasar/Wayland/Protocol/TH.hs b/src/Quasar/Wayland/Protocol/TH.hs
index f24a007..42df064 100644
--- a/src/Quasar/Wayland/Protocol/TH.hs
+++ b/src/Quasar/Wayland/Protocol/TH.hs
@@ -108,8 +108,8 @@ interfaceDecs interface = do
     iName = interfaceN interface
     iT = interfaceT interface
     instanceDecs = [
-      tySynInstD (tySynEqn Nothing (appT (conT ''Request) iT) rT),
-      tySynInstD (tySynEqn Nothing (appT (conT ''Event) iT) eT),
+      tySynInstD (tySynEqn Nothing (appT (conT ''WireRequest) iT) rT),
+      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)) []
       ]
@@ -150,15 +150,15 @@ interfaceDecs interface = do
     eventRecordD :: Q Dec
     eventRecordD = messageRecordD (eventClassN interface) eventContexts
 
-    messageRecordD :: Name -> [MessageContext] -> Q Dec
-    messageRecordD name messageContexts = dataD (cxt []) name [] Nothing [con] []
+messageRecordD :: Name -> [MessageContext] -> Q Dec
+messageRecordD name messageContexts = dataD (cxt []) name [] Nothing [con] []
+  where
+    con = recC name (recField <$> messageContexts)
+    recField :: MessageContext -> Q VarBangType
+    recField msg = varDefaultBangType (mkName msg.msgSpec.name) [t|$(applyArgTypes [t|STM ()|])|]
       where
-        con = recC name (recField <$> messageContexts)
-        recField :: MessageContext -> Q VarBangType
-        recField msg = varDefaultBangType (mkName msg.msgSpec.name) [t|$(applyArgTypes [t|STM ()|])|]
-          where
-            applyArgTypes :: Q Type -> Q Type
-            applyArgTypes xt = foldr (\x y -> [t|$x -> $y|]) xt (argumentType <$> msg.msgSpec.arguments)
+        applyArgTypes :: Q Type -> Q Type
+        applyArgTypes xt = foldr (\x y -> [t|$x -> $y|]) xt (argumentType <$> msg.msgSpec.arguments)
 
 
 interfaceSideInstanceDs :: InterfaceSpec -> Q [Dec]
diff --git a/src/Quasar/Wayland/Registry.hs b/src/Quasar/Wayland/Registry.hs
index e7e545d..bb6ea7c 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 (traceCallback (callback clientRegistry))
+  (wlRegistry, newId) <- newObject @'Client @Interface_wl_registry (traceWireCallback (callback clientRegistry))
   sendMessage wlDisplay $ WireRequest_wl_display_get_registry newId
 
   pure ClientRegistry {
@@ -30,8 +30,8 @@ createClientRegistry wlDisplay = mfix \clientRegistry -> do
     globalsVar
   }
   where
-    callback :: ClientRegistry -> IsInterfaceSide 'Client Interface_wl_registry => Callback 'Client Interface_wl_registry
-    callback clientRegistry = internalFnCallback handler
+    callback :: ClientRegistry -> IsInterfaceSide 'Client Interface_wl_registry => WireCallback 'Client Interface_wl_registry
+    callback clientRegistry = internalFnWireCallback handler
       where
         -- | wl_registry is specified to never change, so manually specifying the callback is safe
         handler :: Object 'Client Interface_wl_registry -> WireEvent_wl_registry -> ProtocolM 'Client ()
-- 
GitLab