From 87e4f59bbe402f079da2594c9ea8bfed8e3763f1 Mon Sep 17 00:00:00 2001
From: Jens Nolte <git@queezle.net>
Date: Thu, 16 Dec 2021 15:58:17 +0100
Subject: [PATCH] Implement wl_registry.bind wrapper

---
 src/Quasar/Wayland/Client.hs          |  2 +
 src/Quasar/Wayland/Client/Registry.hs | 56 ++++++++++++++++++++++++---
 src/Quasar/Wayland/Protocol.hs        |  8 +++-
 src/Quasar/Wayland/Protocol/Core.hs   | 43 +++++++++++++++-----
 src/Quasar/Wayland/Protocol/TH.hs     |  2 +-
 5 files changed, 95 insertions(+), 16 deletions(-)

diff --git a/src/Quasar/Wayland/Client.hs b/src/Quasar/Wayland/Client.hs
index 848a985..0e4448d 100644
--- a/src/Quasar/Wayland/Client.hs
+++ b/src/Quasar/Wayland/Client.hs
@@ -5,6 +5,8 @@ module Quasar.Wayland.Client (
 
   -- * wl_registry
   Registry,
+  bindSingleton,
+  tryBindSingleton,
 ) where
 
 import Control.Concurrent.STM
diff --git a/src/Quasar/Wayland/Client/Registry.hs b/src/Quasar/Wayland/Client/Registry.hs
index 138a46e..8d3cac3 100644
--- a/src/Quasar/Wayland/Client/Registry.hs
+++ b/src/Quasar/Wayland/Client/Registry.hs
@@ -1,9 +1,12 @@
 module Quasar.Wayland.Client.Registry (
   Registry,
-  createRegistry
+  createRegistry,
+  bindSingleton,
+  tryBindSingleton,
 ) where
 
 import Control.Concurrent.STM
+import Control.Monad.Catch
 import Data.HashMap.Strict qualified as HM
 import Data.Tuple (swap)
 import Quasar
@@ -16,10 +19,24 @@ import Quasar.Wayland.Protocol.Generated
 
 data Registry = Registry {
   wlRegistry :: Object 'Client Interface_wl_registry,
-  globalsVar :: TVar (HM.HashMap Word32 (WlString, Word32)),
+  globalsVar :: TVar (HM.HashMap Word32 Global),
   initialSyncComplete :: Awaitable ()
 }
 
+data Global = Global {
+  name :: Word32,
+  interface :: WlString,
+  version :: Word32
+}
+
+newGlobal :: Word32 -> WlString -> Word32 -> STM Global
+newGlobal name interface version = do
+  pure Global {
+    name,
+    interface,
+    version
+  }
+
 createRegistry :: Object 'Client Interface_wl_display -> STM Registry
 createRegistry wlDisplay = mfix \clientRegistry -> do
   globalsVar <- newTVar HM.empty
@@ -42,12 +59,41 @@ createRegistry wlDisplay = mfix \clientRegistry -> do
     messageHandler clientRegistry = EventHandler_wl_registry { global, global_remove }
       where
         global :: Word32 -> WlString -> Word32 -> STM ()
-        global name interface version = do
-          modifyTVar clientRegistry.globalsVar (HM.insert name (interface, version))
+        global name interface version =
+          modifyTVar clientRegistry.globalsVar . HM.insert name =<< newGlobal name interface version
 
         global_remove :: Word32 -> STM ()
         global_remove name = do
           result <- stateTVar clientRegistry.globalsVar (swap . lookupDelete name)
           case result of
             Nothing -> traceM $ "Invalid global removed by server: " <> show name
-            Just (interface, version) -> pure ()
+            Just _ -> pure ()
+
+
+-- | Bind a new client object to a compositor singleton. Throws an exception if the global is not available.
+--
+-- Blocks until the the registry has sent the initial list of globals.
+bindSingleton :: IsInterfaceSide 'Client i => Registry -> STM (Object 'Client i)
+bindSingleton registry = either (throwM . ProtocolUsageError) pure =<< tryBindSingleton registry
+
+-- | Try to bind a new client object to a compositor singleton.
+--
+-- Will block until the the registry has sent the initial list of globals.
+tryBindSingleton :: forall i. IsInterfaceSide 'Client i => Registry -> STM (Either String (Object 'Client i))
+tryBindSingleton registry = do
+  await registry.initialSyncComplete
+
+  globals <- filterInterface . HM.elems <$> readTVar registry.globalsVar
+
+  case globals of
+    [] -> pure $ Left $ mconcat ["No global named ", toString (interfaceName @i), " is available"]
+    (global:[]) -> do
+      let version = min global.version (interfaceVersion @i)
+      (object, newId) <- bindNewObject registry.wlRegistry.objectProtocol version Nothing
+      registry.wlRegistry.bind global.name newId
+      pure $ Right object
+    _ -> pure $ Left $ mconcat ["Cannot bind singleton: multiple globals with type ", toString (interfaceName @i), " are available"]
+
+  where
+    filterInterface :: [Global] -> [Global]
+    filterInterface = filter \global -> global.interface == interfaceName @i
diff --git a/src/Quasar/Wayland/Protocol.hs b/src/Quasar/Wayland/Protocol.hs
index 3599538..6348d33 100644
--- a/src/Quasar/Wayland/Protocol.hs
+++ b/src/Quasar/Wayland/Protocol.hs
@@ -32,13 +32,19 @@ module Quasar.Wayland.Protocol (
   -- ** Classes for generated interfaces
   IsInterface(InterfaceName),
   interfaceName,
+  Version,
+  interfaceVersion,
   Side(..),
   IsSide,
   IsInterfaceSide,
 
-  -- * wl_display interface
+  -- * For wl_display
   handleWlDisplayError,
   handleWlDisplayDeleteId,
+
+  -- * For wl_registry
+  GenericNewId,
+  bindNewObject,
 ) where
 
 import Quasar.Wayland.Protocol.Core
diff --git a/src/Quasar/Wayland/Protocol/Core.hs b/src/Quasar/Wayland/Protocol/Core.hs
index 412705f..60e1808 100644
--- a/src/Quasar/Wayland/Protocol/Core.hs
+++ b/src/Quasar/Wayland/Protocol/Core.hs
@@ -14,6 +14,8 @@ module Quasar.Wayland.Protocol.Core (
   Side(..),
   IsInterface(..),
   interfaceName,
+  Version,
+  interfaceVersion,
   IsInterfaceSide(..),
   IsInterfaceHandler(..),
   Object(objectProtocol),
@@ -42,6 +44,7 @@ module Quasar.Wayland.Protocol.Core (
   sendMessage,
   newObject,
   newObjectFromId,
+  bindNewObject,
   getObject,
   lookupObject,
 
@@ -59,7 +62,6 @@ module Quasar.Wayland.Protocol.Core (
 
   -- * Message decoder operations
   WireFormat(..),
-  dropRemaining,
   invalidOpcode,
 ) where
 
@@ -96,12 +98,14 @@ toGenericObjectId (ObjectId oId) = GenericObjectId oId
 
 type Opcode = Word16
 
+type Version = Word32
+
 
 newtype NewId (j :: Symbol) = NewId (ObjectId j)
   deriving newtype (Eq, Show)
 
-newtype GenericNewId = GenericNewId GenericObjectId
-  deriving newtype (Eq, Show)
+data GenericNewId = GenericNewId WlString Version Word32
+  deriving stock (Eq, Show)
 
 
 -- | Signed 24.8 decimal numbers.
@@ -128,9 +132,6 @@ toString :: WlString -> String
 toString (WlString bs) = BSUTF8.toString bs
 
 
-dropRemaining :: Get ()
-dropRemaining = void getRemainingLazyByteString
-
 
 class (Eq a, Show a) => WireFormat a where
   putArgument :: a -> ProtocolM s (Put, Int)
@@ -178,9 +179,13 @@ instance KnownSymbol j => WireFormat (NewId (j :: Symbol)) where
   showArgument (NewId newId) = "new " <> symbolVal @j Proxy <> "@" <> show newId
 
 instance WireFormat GenericNewId where
-  putArgument (GenericNewId newId) = putArgument newId
-  getArgument = GenericNewId <<$>> getArgument
-  showArgument newId = "new [unknown]@" <> show newId
+  putArgument (GenericNewId interface version newId) = do
+    (put1, s1) <- putArgument interface
+    (put2, s2) <- putArgument version
+    (put3, s3) <- putArgument newId
+    pure (put1 >> put2 >> put3, s1 + s2 + s3)
+  getArgument = GenericNewId <<$>> getArgument <<*>> getArgument <<*>> getArgument
+  showArgument (GenericNewId interface version newId) = mconcat ["new ", toString interface, "[v", show version, "]@", show newId]
 
 instance WireFormat Void where
   putArgument = absurd
@@ -193,6 +198,7 @@ class (
     IsMessage (WireRequest i),
     IsMessage (WireEvent i),
     KnownSymbol (InterfaceName i),
+    KnownNat (InterfaceVersion i),
     Typeable i
   )
   => IsInterface i where
@@ -201,10 +207,14 @@ class (
   type WireRequest i
   type WireEvent i
   type InterfaceName i :: Symbol
+  type InterfaceVersion i :: Nat
 
 interfaceName :: forall i. IsInterface i => WlString
 interfaceName = fromString $ symbolVal @(InterfaceName i) Proxy
 
+interfaceVersion :: forall i. IsInterface i => Word32
+interfaceVersion = fromIntegral $ natVal @(InterfaceVersion i) Proxy
+
 class Typeable s => IsSide (s :: Side) where
   type MessageHandler s i
   type WireUp s i
@@ -557,6 +567,21 @@ newObjectFromId messageHandler (NewId oId) = do
   pure object
 
 
+-- | Create an object. The caller is responsible for sending the 'NewId' immediately (exactly once and before using the
+-- object).
+--
+-- For implementing wl_registry.bind (which is low-level protocol functionality, but which depends on generated code).
+bindNewObject
+  :: forall i. IsInterfaceSide 'Client i
+  => ProtocolHandle 'Client
+  -> Version
+  -> Maybe (MessageHandler 'Client i)
+  -> STM (Object 'Client i, GenericNewId)
+bindNewObject protocol version messageHandler = runProtocolM protocol do
+  (object, NewId (ObjectId newId)) <- newObject messageHandler
+  pure (object, GenericNewId (interfaceName @i) version newId)
+
+
 fromSomeObject
   :: forall s i m. IsInterfaceSide s i
   => SomeObject s -> Either String (Object s i)
diff --git a/src/Quasar/Wayland/Protocol/TH.hs b/src/Quasar/Wayland/Protocol/TH.hs
index 822e0ff..cddb2ba 100644
--- a/src/Quasar/Wayland/Protocol/TH.hs
+++ b/src/Quasar/Wayland/Protocol/TH.hs
@@ -42,7 +42,7 @@ newtype EventSpec = EventSpec {messageSpec :: MessageSpec}
 
 data MessageSpec = MessageSpec {
   name :: String,
-  since :: Maybe Integer,
+  since :: Maybe Version,
   description :: Maybe DescriptionSpec,
   opcode :: Opcode,
   arguments :: [ArgumentSpec],
-- 
GitLab