Add createProxy and add (dummy) TH implementation

src/Quasar/Wayland/Protocol/Core.hs

@@ -13,7 +13,7 @@ module Quasar.Wayland.Protocol.Core (
   IsSide(..),
   Side(..),
   IsInterface(..),
-  IsInterfaceSide,
+  IsInterfaceSide(..),
   IsInterfaceHandler(..),
   Object,
   IsObject,
@@ -226,6 +226,7 @@ class (
     IsMessage (WireDown s i)
   )
   => IsInterfaceSide (s :: Side) i where
+  createProxy :: Object s i -> Up s i
 
 
 getWireDown :: forall s i. IsInterfaceSide s i => Object s i -> Opcode -> Get (ProtocolM s (WireDown s i))
@@ -452,7 +453,7 @@ initializeProtocol wlDisplayWireCallback initializationAction = do
   }
   writeTVar stateVar (Right state)
 
-  let wlDisplay = Object protocol wlDisplayId undefined undefined wlDisplayWireCallback
+  let wlDisplay = Object protocol wlDisplayId (createProxy wlDisplay) undefined wlDisplayWireCallback
   modifyTVar' objectsVar (HM.insert wlDisplayId (SomeObject wlDisplay))
 
   result <- runReaderT (initializationAction wlDisplay) state
@@ -546,7 +547,7 @@ newObjectFromId (NewId oId) callback = do
   protocol <- askProtocol
   let
     genericObjectId = toGenericObjectId oId
-    object = Object protocol genericObjectId undefined undefined callback
+    object = Object protocol genericObjectId (createProxy object) undefined callback
     someObject = SomeObject object
   modifyProtocolVar (.objectsVar) (HM.insert genericObjectId someObject)
   pure object

src/Quasar/Wayland/Protocol/TH.hs

@@ -90,8 +90,9 @@ tellQs = tell <=< lift
 interfaceDecs :: InterfaceSpec -> Q ([Dec], [Dec])
 interfaceDecs interface = do
   public <- execWriterT do
-    tellQ $ dataD (pure []) iName [] Nothing [] [derivingInterfaceClient, derivingInterfaceServer]
+    tellQ $ dataD (pure []) iName [] Nothing [] []
     tellQ $ instanceD (pure []) [t|IsInterface $iT|] instanceDecs
+    tellQs $ interfaceSideInstanceDs interface
 
     when (length interface.requests > 0) do
       tellQ requestRecordD
@@ -170,10 +171,12 @@ messageRecordD name messageContexts = dataD (cxt []) name [] Nothing [con] []
 
 interfaceSideInstanceDs :: InterfaceSpec -> Q [Dec]
 interfaceSideInstanceDs interface = execWriterT do
-  tellQs [d|instance IsInterfaceSide 'Client $iT|]
-  tellQs [d|instance IsInterfaceSide 'Server $iT|]
+  tellQ $ instanceD (pure []) ([t|IsInterfaceSide 'Client $iT|]) [createProxyD Client]
+  tellQ $ instanceD (pure []) ([t|IsInterfaceSide 'Server $iT|]) [createProxyD Server]
   where
     iT = interfaceT interface
+    createProxyD :: Side -> Q Dec
+    createProxyD side = funD 'createProxy [clause [] (normalB [|undefined|]) []]
 
 
 interfaceN :: InterfaceSpec -> Name
@@ -289,12 +292,6 @@ derivingEq = derivClause (Just StockStrategy) [[t|Eq|]]
 derivingShow :: Q DerivClause
 derivingShow = derivClause (Just StockStrategy) [[t|Show|]]
 
-derivingInterfaceClient :: Q DerivClause
-derivingInterfaceClient = derivClause (Just AnyclassStrategy) [[t|IsInterfaceSide 'Client|]]
-
-derivingInterfaceServer :: Q DerivClause
-derivingInterfaceServer = derivClause (Just AnyclassStrategy) [[t|IsInterfaceSide 'Server|]]
-
 -- | Map an argument to its high-level api type
 argumentType :: ArgumentSpec -> Q Type
 argumentType argSpec = liftArgumentType argSpec.argType