From 25f00dfbf4655b53ba99c6bba74e6c8ad28d8b50 Mon Sep 17 00:00:00 2001
From: Jens Nolte <git@queezle.net>
Date: Wed, 15 Dec 2021 06:27:29 +0100
Subject: [PATCH] Implement object lookup
---
src/Quasar/Wayland/Protocol/Core.hs | 42 ++++++++++++++++++++++++++---
1 file changed, 38 insertions(+), 4 deletions(-)
diff --git a/src/Quasar/Wayland/Protocol/Core.hs b/src/Quasar/Wayland/Protocol/Core.hs
index 509cf03..2650d89 100644
--- a/src/Quasar/Wayland/Protocol/Core.hs
+++ b/src/Quasar/Wayland/Protocol/Core.hs
@@ -41,6 +41,7 @@ module Quasar.Wayland.Protocol.Core (
newObject,
newObjectFromId,
getObject,
+ lookupObject,
-- * Protocol exceptions
WireCallbackFailed(..),
@@ -70,6 +71,7 @@ import Data.HashMap.Strict (HashMap)
import Data.HashMap.Strict qualified as HM
import Data.Proxy
import Data.String (IsString(..))
+import Data.Typeable (Typeable, cast)
import Data.Void (absurd)
import GHC.Conc (unsafeIOToSTM)
import GHC.TypeLits
@@ -183,7 +185,8 @@ instance WireFormat Void where
class (
IsMessage (WireRequest i),
IsMessage (WireEvent i),
- KnownSymbol (InterfaceName i)
+ KnownSymbol (InterfaceName i),
+ Typeable i
)
=> IsInterface i where
type RequestHandler i
@@ -195,7 +198,7 @@ class (
interfaceName :: forall i. IsInterface i => String
interfaceName = symbolVal @(InterfaceName i) Proxy
-class IsSide (s :: Side) where
+class Typeable s => IsSide (s :: Side) where
type MessageHandler s i
type WireUp s i
type WireDown s i
@@ -241,6 +244,7 @@ class IsInterfaceSide s i => IsInterfaceHandler s i a where
-- | Data kind
data Side = Client | Server
+ deriving stock (Eq, Show, Typeable)
-- | An object belonging to a wayland connection.
@@ -249,6 +253,8 @@ data Object s i = IsInterfaceSide s i => Object {
objectId :: ObjectId (InterfaceName i),
messageHandler :: TVar (Maybe (MessageHandler s i))
}
+ deriving stock Typeable
+
getMessageHandler :: Object s i -> STM (MessageHandler s i)
getMessageHandler object = maybe retry pure =<< readTVar object.messageHandler
@@ -359,6 +365,10 @@ data ServerError = ServerError Word32 String
deriving stock Show
deriving anyclass Exception
+data InvalidObject = InvalidObject String
+ deriving stock Show
+ deriving anyclass Exception
+
-- * Protocol state and monad plumbing
-- | Top-level protocol handle (used e.g. to send/receive data)
@@ -550,11 +560,35 @@ newObjectFromId messageHandler (NewId oId) = do
pure object
+fromSomeObject
+ :: forall s i m. IsInterfaceSide s i
+ => SomeObject s -> Either String (Object s i)
+fromSomeObject (UnknownObject interface _) =
+ Left $ mconcat ["Object is of unknown interface ", interface]
+fromSomeObject (SomeObject someObject) =
+ case cast someObject of
+ Nothing -> Left $ mconcat ["Expected object for interface ", interfaceName @i, ", but object is ", objectInterfaceName someObject]
+ Just object -> pure object
+
+
+lookupObject
+ :: forall s i. IsInterfaceSide s i
+ => ObjectId (InterfaceName i)
+ -> ProtocolM s (Either String (Object s i))
+lookupObject oId = do
+ objects <- readProtocolVar (.objectsVar)
+ pure case HM.lookup (toGenericObjectId oId) objects of
+ Nothing -> Left $ mconcat ["No object with id ", show oId, " is registered"]
+ Just someObject ->
+ case fromSomeObject someObject of
+ Left err -> Left err
+ Right object -> pure object
+
getObject
- :: IsInterfaceSide s i
+ :: forall s i. IsInterfaceSide s i
=> ObjectId (InterfaceName i)
-> ProtocolM s (Object s i)
-getObject = undefined
+getObject oId = either (throwM . InvalidObject) pure =<< lookupObject oId
--
GitLab