create globals

4 files changed, 47 insertions, 12 deletions

diff --git a/highway/Main.hs b/highway/Main.hs
index 58049df..191279a 100644
--- a/highway/Main.hs
+++ b/highway/Main.hs
@@ -48,6 +48,7 @@ handleRequest r
   | Just (BindOutput o)          <- fromRequest r = do outputs %= M.insert o Output
                                                        sendEvent o $ WLOutput.EvGeometry geometry
                                                        sendEvent o $ WLOutput.EvDone
+                                                       liftIO $ putStrLn $ "Created output " ++ show o
                                                        flushEvents
   | Just ReqSIGINT               <- fromRequest r = do c <- interruptedCount <%= (+1)
                                                        liftIO $ putStrLn $ "Received SIGINT " ++ show c ++ "/3"
@@ -59,6 +60,6 @@ main = void $ withDisplay (State M.empty 0) $ do
   socket <- bindSocket
   liftIO $ putStrLn $ "Listening on socket: " ++ socket
   registerSignalEvent ReqSIGINT 2
-  output <- registerGlobal BindOutput
+  output <- registerGlobal BindOutput 4
   processRequests handleRequest
   unregisterGlobal output
diff --git a/protocols/Wayland/Protocols/Core/WLOutput.hs b/protocols/Wayland/Protocols/Core/WLOutput.hs
index e0c0d37..1274855 100644
--- a/protocols/Wayland/Protocols/Core/WLOutput.hs
+++ b/protocols/Wayland/Protocols/Core/WLOutput.hs
@@ -21,6 +21,7 @@ instance ResourceClass Handle where
   type ResourceEvent   Handle = Event
   type ResourceRequest Handle = Request
   objectID (Handle h) = h
+  fromID = Handle
   interface _ = InterfaceDesc { ifName     = "wl_output"
                               , ifVersion  = 4
                               , ifRequests = [ MessageDesc { msgName         = "release"
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 ()
diff --git a/wayland/Wayland/Server/System.hsc b/wayland/Wayland/Server/System.hsc
index f758a65..6fcd52c 100644
--- a/wayland/Wayland/Server/System.hsc
+++ b/wayland/Wayland/Server/System.hsc
@@ -6,6 +6,7 @@ module Wayland.Server.System where
 
 import Foreign (FunPtr, Ptr, Storable(..))
 import Foreign.C (CString, CInt(..))
+import Data.Word (Word32)
 
 data WLMessage
   = WLMessage { msgName      :: CString
@@ -27,12 +28,19 @@ data WLInterface
 newtype WLDisplay     = WLDisplay     (Ptr WLDisplay)
 newtype WLEventLoop   = WLEventLoop   (Ptr WLEventLoop)
 newtype WLEventSource = WLEventSource (Ptr WLEventSource)
+newtype WLGlobal      = WLGlobal      (Ptr WLGlobal)
+newtype WLClient      = WLClient      (Ptr WLClient)
+newtype WLResource    = WLResource    (Ptr WLResource)
 
 type WLEventLoopSignalFunc = CInt -> Ptr () -> IO CInt
+type WLGlobalBindFunc      = WLClient -> Ptr () -> Word32 -> Word32 -> IO ()
 
 foreign import ccall "wrapper"
   wrapWLEventLoopSignalFunc :: WLEventLoopSignalFunc -> IO (FunPtr WLEventLoopSignalFunc)
 
+foreign import ccall "wrapper"
+  wrapWLGlobalBindFunc :: WLGlobalBindFunc -> IO (FunPtr WLGlobalBindFunc)
+
 foreign import ccall "wl_display_create"
   wlDisplayCreate :: IO WLDisplay
 
@@ -54,6 +62,12 @@ foreign import ccall "wl_display_get_event_loop"
 foreign import ccall "wl_event_loop_add_signal"
   wlEventLoopAddSignal :: WLEventLoop -> CInt -> FunPtr WLEventLoopSignalFunc -> Ptr () -> IO WLEventSource
 
+foreign import ccall "wl_global_create"
+  wlGlobalCreate :: WLDisplay -> Ptr WLInterface -> CInt -> Ptr () -> FunPtr WLGlobalBindFunc -> IO WLGlobal
+
+foreign import ccall "wl_resource_create"
+  wlResourceCreate :: WLClient -> Ptr WLInterface -> CInt -> Word32 -> IO WLResource
+
 instance Storable WLMessage where
   sizeOf    _ = #{size struct wl_message}
   alignment _ = #{alignment struct wl_message}