dispatch events

1 files changed, 73 insertions, 2 deletions

diff --git a/wayland/Wayland/Server/System.hsc b/wayland/Wayland/Server/System.hsc
index d4f5b50..0f68578 100644
--- a/wayland/Wayland/Server/System.hsc
+++ b/wayland/Wayland/Server/System.hsc
@@ -4,7 +4,7 @@ module Wayland.Server.System where
 
 #include <wayland-server.h>
 
-import Foreign (FunPtr, Ptr, Storable(..), Int32)
+import Foreign (FunPtr, Ptr, Storable(..), Int32, castPtr)
 import Foreign.C (CString, CInt(..), CSize)
 import Data.Word (Word32)
 
@@ -56,12 +56,21 @@ foreign import ccall "wrapper"
 foreign import ccall "wrapper"
   wrapWLGlobalBindFunc :: WLGlobalBindFunc -> IO (FunPtr WLGlobalBindFunc)
 
+foreign import ccall "wrapper"
+  wrapWLDispatcherFunc :: WLDispatcherFunc -> IO (FunPtr WLDispatcherFunc)
+
+foreign import ccall "wrapper"
+  wrapWLResourceDestroyFunc :: WLResourceDestroyFunc -> IO (FunPtr WLResourceDestroyFunc)
+
 foreign import ccall "wl_display_create"
   wlDisplayCreate :: IO WLDisplay
 
 foreign import ccall "wl_display_destroy"
   wlDisplayDestroy :: WLDisplay -> IO ()
 
+foreign import ccall "wl_display_flush_clients"
+  wlDisplayFlushClients :: WLDisplay -> IO ()
+
 foreign import ccall "wl_display_add_socket_auto"
   wlDisplayAddSocketAuto :: WLDisplay -> IO CString
 
@@ -86,6 +95,15 @@ foreign import ccall "wl_resource_create"
 foreign import ccall "wl_resource_set_dispatcher"
   wlResourceSetDispatcher :: WLResource -> FunPtr WLDispatcherFunc -> Ptr () -> Ptr () -> FunPtr WLResourceDestroyFunc -> IO ()
 
+foreign import ccall "wl_resource_get_user_data"
+  wlResourceGetUserData :: WLResource -> IO (Ptr ())
+
+foreign import ccall "wl_resource_post_event_array"
+  wlResourcePostEventArray :: WLResource -> Word32 -> Ptr WLArgument -> IO ()
+
+foreign import ccall "wl_resource_destroy"
+  wlResourceDestroy :: WLResource -> IO ()
+
 wlArgumentGetInt :: Ptr WLArgument -> IO Int32
 wlArgumentGetInt = #{peek union wl_argument, i}
 
@@ -98,7 +116,7 @@ wlArgumentGetFixed = #{peek union wl_argument, f}
 wlArgumentGetString :: Ptr WLArgument -> IO CString
 wlArgumentGetString = #{peek union wl_argument, s}
 
-wlArgumentGetObject :: Ptr WLArgument -> IO WLResource
+wlArgumentGetObject :: Ptr WLArgument -> IO (Ptr ())
 wlArgumentGetObject = #{peek union wl_argument, o}
 
 wlArgumentGetNewID :: Ptr WLArgument -> IO Word32
@@ -110,6 +128,30 @@ wlArgumentGetArray = #{peek union wl_argument, a}
 wlArgumentGetFD :: Ptr WLArgument -> IO Int32
 wlArgumentGetFD = #{peek union wl_argument, h}
 
+wlArgumentSetInt :: Int32 -> Ptr WLArgument -> IO ()
+wlArgumentSetInt v p = #{poke union wl_argument, i} p v
+
+wlArgumentSetUInt :: Word32 -> Ptr WLArgument -> IO ()
+wlArgumentSetUInt v p = #{poke union wl_argument, u} p v
+
+wlArgumentSetFixed :: WLFixed -> Ptr WLArgument -> IO ()
+wlArgumentSetFixed v p = #{poke union wl_argument, f} p v
+
+wlArgumentSetString :: CString -> Ptr WLArgument -> IO ()
+wlArgumentSetString v p = #{poke union wl_argument, s} p v
+
+wlArgumentSetObject :: Ptr () -> Ptr WLArgument -> IO ()
+wlArgumentSetObject v p = #{poke union wl_argument, o} p v
+
+wlArgumentSetNewID :: Word32 -> Ptr WLArgument -> IO ()
+wlArgumentSetNewID v p = #{poke union wl_argument, n} p v
+
+wlArgumentSetArray :: Ptr WLArray -> Ptr WLArgument -> IO ()
+wlArgumentSetArray v p = #{poke union wl_argument, a} p v
+
+wlArgumentSetFD :: Int32 -> Ptr WLArgument -> IO ()
+wlArgumentSetFD v p = #{poke union wl_argument, h} p v
+
 instance Storable WLMessage where
   sizeOf    _ = #{size struct wl_message}
   alignment _ = #{alignment struct wl_message}
@@ -152,3 +194,32 @@ instance Storable WLInterface where
     #{poke struct wl_interface, event_count}  p $ ifEventCount  m
     #{poke struct wl_interface, events}       p $ ifEvents      m
     return ()
+
+instance Storable WLArray where
+  sizeOf    _ = #{size struct wl_array}
+  alignment _ = #{alignment struct wl_array}
+  peek p = do
+    aSize  <- #{peek struct wl_array, size}  p
+    aAlloc <- #{peek struct wl_array, alloc} p
+    aData  <- #{peek struct wl_array, data}  p
+    return $ WLArray { arrSize  = aSize
+                     , arrAlloc = aAlloc
+                     , arrData  = aData
+                     }
+  poke p m = do
+    #{poke struct wl_array, size}  p $ arrSize  m
+    #{poke struct wl_array, alloc} p $ arrAlloc m
+    #{poke struct wl_array, data}  p $ arrData  m
+    return ()
+
+instance Storable WLFixed where
+  sizeOf    _             = sizeOf    (undefined :: #{type wl_fixed_t})
+  alignment _             = alignment (undefined :: #{type wl_fixed_t})
+  peek      p             = WLFixed <$> peek (castPtr p)
+  poke      p (WLFixed v) = poke (castPtr p) v
+
+instance Storable WLArgument where
+  sizeOf    _   = #{size union wl_argument}
+  alignment _   = #{alignment union wl_argument}
+  peek      _   = pure WLArgument
+  poke      _ _ = pure ()