From 3387f92245dae08bc1125829dd542ec2e13c28fd Mon Sep 17 00:00:00 2001
From: Hannes Schulze <haschu0103@outlook.de>
Date: Sun, 4 Aug 2024 21:37:33 +0200
Subject: create globals

---
 wayland/Wayland/Server.hs | 41 ++++++++++++++++++++++++++++++-----------
 1 file changed, 30 insertions(+), 11 deletions(-)

(limited to 'wayland/Wayland/Server.hs')

diff --git a/wayland/Wayland/Server.hs b/wayland/Wayland/Server.hs
index b0c5b89..7d60512 100644
--- a/wayland/Wayland/Server.hs
+++ b/wayland/Wayland/Server.hs
@@ -5,6 +5,7 @@
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE UndecidableInstances #-}
 {-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 
 module Wayland.Server
   ( Request(..)
@@ -30,7 +31,7 @@ module Wayland.Server
   , requestTermination
   ) where
 
-import Data.Typeable (Typeable, Proxy, cast, TypeRep, typeRep)
+import Data.Typeable (Typeable, Proxy(..), cast, TypeRep, typeRep)
 import Data.Kind (Type)
 import Control.Monad.State.Strict (StateT, MonadState(..), MonadIO(..), runStateT)
 import Lens.Micro.Mtl.Internal (Zoom(..), Zoomed)
@@ -49,10 +50,11 @@ import Control.Monad (when)
 import Data.Maybe (isJust)
 import qualified Data.Map as M
 import Foreign.Marshal (newArray)
+import Data.Word (Word32)
 
 data Global = Global
 
-newtype ObjectID = ObjectID String
+data ObjectID = ObjectID
   deriving (Show, Eq, Ord)
 
 data Nullability
@@ -113,14 +115,13 @@ makeLenses ''DisplayState
 class Typeable r => ResourceClass r where
   type ResourceRequest r :: Type
   type ResourceEvent   r :: Type
-  objectID  :: r       -> ObjectID
-  interface :: Proxy r -> InterfaceDesc
-
+  objectID  :: r        -> ObjectID
+  fromID    :: ObjectID -> r
+  interface :: Proxy r  -> InterfaceDesc
 
 instance Show Request where
   show (Request r) = show r
 
-
 type instance Zoomed (DisplayM s) = Zoomed (StateT s (StateT DisplayState (ReaderT Display IO)))
 
 instance Zoom (DisplayM s) (DisplayM t) s t where
@@ -173,16 +174,33 @@ processRequests h = do
   liftDisplayState $ put displayStateAfter
 
 sendEvent :: ResourceClass r => r -> ResourceEvent r -> DisplayM s ()
-sendEvent _ _ = undefined
+sendEvent _ _ = pure () -- TODO
 
 flushEvents :: DisplayM s ()
-flushEvents = undefined
+flushEvents = pure () -- TODO
 
 destroyResource :: ResourceClass r => r -> DisplayM s ()
-destroyResource _ = undefined
+destroyResource _ = pure () -- TODO
 
-registerGlobal :: ResourceClass r => RequestClass req => (r -> req) -> DisplayM s Global
-registerGlobal _ = pure Global
+registerGlobal :: forall r req s. ResourceClass r => RequestClass req => (r -> req) -> Int -> DisplayM s Global
+registerGlobal mkReq version = do
+  disp <- getDisplay
+  iface <- getInterface (Proxy :: Proxy r)
+  let createObject :: Sys.WLClient -> Ptr () -> Word32 -> Word32 -> IO ()
+      createObject client _ ver objID = do
+        _ <- Sys.wlResourceCreate client iface (fromIntegral ver) objID
+        -- TODO: Bind functions
+        -- TODO: Wrap resource into ObjectID
+        let req = mkReq (fromID ObjectID)
+        runRequest disp (Request req)
+        pure ()
+  liftIO $ do
+    func <- Sys.wrapWLGlobalBindFunc createObject
+    _ <- Sys.wlGlobalCreate (display disp) iface (fromIntegral version) nullPtr func
+    -- TODO: Free func
+    -- TODO: Return proper Global
+    pure ()
+  pure Global
 
 unregisterGlobal :: Global -> DisplayM s ()
 unregisterGlobal _ = pure ()
@@ -202,6 +220,7 @@ registerSignalEvent r sig = do
     func <- Sys.wrapWLEventLoopSignalFunc $ \_ _ -> runRequest disp (Request r) $> 0
     _ <- Sys.wlEventLoopAddSignal loop sig func nullPtr
     -- TODO: Free func
+    -- TODO: Return event source handle
     pure ()
 
 requestTermination :: DisplayM s ()
-- 
cgit v1.3.1