refactor Wayland.Server.System

1 files changed, 35 insertions, 25 deletions

diff --git a/wayland/Wayland/Server.hs b/wayland/Wayland/Server.hs
index 89a9780..30300de 100644
--- a/wayland/Wayland/Server.hs
+++ b/wayland/Wayland/Server.hs
@@ -45,7 +45,7 @@ import qualified Wayland.Server.System as Sys
 import Control.Monad.Trans (MonadTrans(..))
 import Foreign.C (peekCString, newCString, withCString)
 import Foreign.C.Types (CInt)
-import Foreign (Ptr, nullPtr, new, newStablePtr, castStablePtrToPtr, castPtrToStablePtr, deRefStablePtr, freeStablePtr, Storable(..), Int32, castPtr, withArray, with, allocaArray0)
+import Foreign (Ptr, nullPtr, new, newStablePtr, castStablePtrToPtr, castPtrToStablePtr, deRefStablePtr, freeStablePtr, Storable(..), Int32, castPtr, withArray, with, allocaArray0, FunPtr, plusPtr)
 import Data.IORef (IORef, newIORef, writeIORef, readIORef)
 import Control.Monad.Reader (ReaderT, MonadReader(..), runReaderT)
 import Control.Exception (bracket)
@@ -57,10 +57,13 @@ import Foreign.Marshal (newArray)
 import Data.Word (Word32)
 import System.Mem.StableName (StableName, makeStableName)
 import Data.Hashable (Hashable(..))
-import Foreign.Ptr (plusPtr)
 import Control.Monad.Cont (ContT(..))
 
-data Global = Global
+data EventSource = EventSource (FunPtr Sys.WLEventLoopSignalFunc) (IORef Sys.WLEventSource)
+  deriving (Eq)
+
+data Global = Global (FunPtr Sys.WLGlobalBindFunc) (IORef Sys.WLGlobal)
+  deriving (Eq)
 
 -- IORef set to nullPtr once destroyed.
 data ObjectID = ObjectID (StableName (IORef Sys.WLResource)) (IORef Sys.WLResource)
@@ -246,18 +249,17 @@ registerGlobal mkBindReq mkUnbindReq version = do
         handlePtr <- newStablePtr objID
         dis <- Sys.wrapWLDispatcherFunc dispatcher
         des <- Sys.wrapWLResourceDestroyFunc destroy
-        -- TODO: Free functions
+        -- TODO: Free dis and des
         Sys.wlResourceSetDispatcher res dis nullPtr (castStablePtrToPtr handlePtr) des
         let req = mkBindReq (fromID objID)
         runRequest disp (Request req)
         pure ()
   liftIO $ do
     func <- Sys.wrapWLGlobalBindFunc createObject
-    _ <- Sys.wlGlobalCreate (display disp) iface (fromIntegral version) nullPtr func
+    global <- Sys.wlGlobalCreate (display disp) iface (fromIntegral version) nullPtr func
+    globalRef <- newIORef global
     -- TODO: Free func
-    -- TODO: Return proper Global
-    pure ()
-  pure Global
+    pure $ Global func globalRef
 
 unregisterGlobal :: Global -> DisplayM s ()
 unregisterGlobal _ = pure ()
@@ -269,16 +271,16 @@ runRequest disp r = do
     Just handler -> handleEvent handler r
     Nothing      -> putStrLn $ "Lost request because no event loop is active: " ++ show r
 
-registerSignalEvent :: RequestClass req => req -> CInt -> DisplayM s ()
+registerSignalEvent :: RequestClass req => req -> CInt -> DisplayM s EventSource
 registerSignalEvent r sig = do
   disp <- getDisplay
   liftIO $ do
     loop <- Sys.wlDisplayGetEventLoop (display disp)
     func <- Sys.wrapWLEventLoopSignalFunc $ \_ _ -> runRequest disp (Request r) $> 0
-    _ <- Sys.wlEventLoopAddSignal loop sig func nullPtr
+    src <- Sys.wlEventLoopAddSignal loop sig func nullPtr
+    srcRef <- newIORef src
     -- TODO: Free func
-    -- TODO: Return event source handle
-    pure ()
+    pure $ EventSource func srcRef
 
 requestTermination :: DisplayM s ()
 requestTermination = do
@@ -358,32 +360,40 @@ advanceIterator = do
   when (remaining == 0) (fail "Out of range for argument")
   pure next
 
-getObjectForHandle :: ResourceClass r => r -> IO (Ptr a)
+getObjectForHandle :: ResourceClass r => r -> IO Sys.WLResource
 getObjectForHandle r = fetch (objectID r)
   where fetch (ObjectID _ handle) = readIORef handle >>= check
-        check (Sys.WLResource ptr) | ptr == nullPtr = fail "Invalid object handle."
-                                   | otherwise      = pure (castPtr ptr)
+        check res@(Sys.WLResource ptr) | ptr == nullPtr = fail "Invalid object handle."
+                                       | otherwise      = pure res
 
 liftCont :: ((a -> IO r) -> IO r) -> ArgumentIterator r a
 liftCont = ArgumentIterator . lift . ContT
 
 instance ArgumentMarshaller (ArgumentIterator r) where
-  marshalInt    v = advanceIterator >>= (liftIO . Sys.wlArgumentSetInt   (fromIntegral v))
-  marshalUInt   v = advanceIterator >>= (liftIO . Sys.wlArgumentSetUInt  (fromIntegral v))
-  marshalFixed  v = advanceIterator >>= (liftIO . Sys.wlArgumentSetFixed (Sys.WLFixed (round (v * 256))))
-  marshalFD     v = advanceIterator >>= (liftIO . Sys.wlArgumentSetFD    (fromIntegral v))
+  marshalInt v = do
+    arg <- advanceIterator
+    liftIO $ Sys.wlArgumentPokeInt arg (fromIntegral v)
+  marshalUInt v = do
+    arg <- advanceIterator
+    liftIO $ Sys.wlArgumentPokeUInt arg (fromIntegral v)
+  marshalFixed v = do
+    arg <- advanceIterator
+    liftIO $ Sys.wlArgumentPokeFixed arg (Sys.WLFixed (round (v * 256)))
+  marshalFD v = do
+    arg <- advanceIterator
+    liftIO $ Sys.wlArgumentPokeFD arg (fromIntegral v)
   marshalString v = do
     arg <- advanceIterator
     str <- liftCont $ withCString v
-    liftIO $ Sys.wlArgumentSetString str arg
+    liftIO $ Sys.wlArgumentPokeString arg str
   marshalObject v = do
     arg <- advanceIterator
     obj <- liftIO $ getObjectForHandle v
-    liftIO $ Sys.wlArgumentSetObject obj arg
+    liftIO $ Sys.wlArgumentPokeObject arg obj
   marshalNewID v = do
     arg <- advanceIterator
     obj <- liftIO $ getObjectForHandle v
-    liftIO $ Sys.wlArgumentSetObject obj arg
+    liftIO $ Sys.wlArgumentPokeObject arg obj
   marshalArray v = do
     arg <- advanceIterator
     let len = fromIntegral $ length v * sizeOf (head v)
@@ -392,7 +402,7 @@ instance ArgumentMarshaller (ArgumentIterator r) where
                                          , Sys.arrAlloc = len
                                          , Sys.arrData  = castPtr buf
                                          }
-    liftIO $ Sys.wlArgumentSetArray arr arg
+    liftIO $ Sys.wlArgumentPokeArray arg arr
 
 sendEvent :: forall r s. ResourceClass r => r -> ResourceEvent r -> DisplayM s ()
 sendEvent res e = liftIO $ do
@@ -402,7 +412,7 @@ sendEvent res e = liftIO $ do
     let s = ArgumentIteratorState { _argNext          = buffer
                                   , _argRemaining     = length params
                                   }
-        handler (opcode, _) = Sys.wlResourcePostEventArray (Sys.WLResource ptr) (fromIntegral opcode) buffer
+        handler (opcode, _) = Sys.wlResourcePostEventArray ptr (fromIntegral opcode) buffer
     in runContT (runStateT (runArgumentIterator (marshalEvent (Proxy :: Proxy r) e)) s) handler
 
 flushEvents :: DisplayM s ()
@@ -413,4 +423,4 @@ flushEvents = do
 destroyResource :: ResourceClass r => r -> DisplayM s ()
 destroyResource r = liftIO $ do
   ptr <- getObjectForHandle r
-  Sys.wlResourceDestroy (Sys.WLResource ptr)
+  Sys.wlResourceDestroy ptr