dispatch events

7 files changed, 374 insertions, 85 deletions

diff --git a/flake.nix b/flake.nix
index c6ba3d0..877279d 100644
--- a/flake.nix
+++ b/flake.nix
@@ -27,7 +27,7 @@
           in
           pkgs.mkShell {
             inherit name;
-            packages = [ haskell pkgs.pkg-config pkgs.wayland pkgs.libffi pkgs.cabal-install ];
+            packages = [ haskell pkgs.gdb pkgs.pkg-config pkgs.wayland pkgs.libffi pkgs.cabal-install ];
             hardeningDisable = [ "fortify" ];
           };
       in
diff --git a/highway/Main.hs b/highway/Main.hs
index 191279a..617a0ee 100644
--- a/highway/Main.hs
+++ b/highway/Main.hs
@@ -21,7 +21,8 @@ geometry = WLOutput.Geometry { WLOutput.x              = 0
                              }
 
 data BindRequest
-  = BindOutput WLOutput.Handle
+  = BindOutput   WLOutput.Handle
+  | UnbindOutput WLOutput.Handle
   deriving (Typeable, Show)
 
 data SignalRequest
@@ -43,13 +44,13 @@ makeLenses ''State
 
 handleRequest :: Request -> DisplayM State ()
 handleRequest r
-  | Just (WLOutput.ReqRelease o) <- fromRequest r = do outputs %= M.delete o
-                                                       destroyResource o
-  | Just (BindOutput o)          <- fromRequest r = do outputs %= M.insert o Output
+  | Just (WLOutput.ReqRelease o) <- fromRequest r = destroyResource o
+  | Just (BindOutput o)          <- fromRequest r = do outs <- outputs <%= M.insert o Output
                                                        sendEvent o $ WLOutput.EvGeometry geometry
                                                        sendEvent o $ WLOutput.EvDone
-                                                       liftIO $ putStrLn $ "Created output " ++ show o
+                                                       liftIO $ putStrLn $ "Created output, outputs: " ++ show outs
                                                        flushEvents
+  | Just (UnbindOutput o)        <- fromRequest r = outputs %= M.delete o
   | Just ReqSIGINT               <- fromRequest r = do c <- interruptedCount <%= (+1)
                                                        liftIO $ putStrLn $ "Received SIGINT " ++ show c ++ "/3"
                                                        when (c >= 3) requestTermination
@@ -60,6 +61,6 @@ main = void $ withDisplay (State M.empty 0) $ do
   socket <- bindSocket
   liftIO $ putStrLn $ "Listening on socket: " ++ socket
   registerSignalEvent ReqSIGINT 2
-  output <- registerGlobal BindOutput 4
+  output <- registerGlobal BindOutput UnbindOutput 4
   processRequests handleRequest
   unregisterGlobal output
diff --git a/protocols/Wayland/Protocols/Core/WLOutput.hs b/protocols/Wayland/Protocols/Core/WLOutput.hs
index 1274855..d6adda2 100644
--- a/protocols/Wayland/Protocols/Core/WLOutput.hs
+++ b/protocols/Wayland/Protocols/Core/WLOutput.hs
@@ -1,5 +1,6 @@
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 
 module Wayland.Protocols.Core.WLOutput
   ( Subpixel(..)
@@ -12,10 +13,72 @@ module Wayland.Protocols.Core.WLOutput
   ) where
 
 import Data.Data (Typeable)
-import Wayland.Server (ResourceClass(..), RequestClass, InterfaceDesc(..), MessageDesc(..), ArgumentDesc(..), Nullability(..), ObjectID)
+import Wayland.Server (ResourceClass(..), RequestClass, InterfaceDesc(..), MessageDesc(..), ArgumentDesc(..), Nullability(..), ObjectID, EventClass, marshalInt, marshalString, marshalUInt)
+import Data.Hashable (Hashable(..))
 
 newtype Handle = Handle ObjectID
-  deriving (Show, Eq, Ord)
+  deriving (Show, Eq, Ord, Hashable)
+
+reqRelease :: MessageDesc
+reqRelease = MessageDesc { msgName         = "release"
+                         , msgSignature    = []
+                         , msgSince        = 3
+                         , msgIsDestructor = True
+                         }
+
+evGeometry :: MessageDesc
+evGeometry = MessageDesc { msgName         = "geometry"
+                         , msgSignature    = [ ArgumentInt
+                                             , ArgumentInt
+                                             , ArgumentInt
+                                             , ArgumentInt
+                                             , ArgumentInt
+                                             , ArgumentString NotNull
+                                             , ArgumentString NotNull
+                                             , ArgumentInt
+                                             ]
+                         , msgSince        = 1
+                         , msgIsDestructor = False
+                         }
+
+evMode :: MessageDesc
+evMode = MessageDesc { msgName         = "mode"
+                     , msgSignature    = [ ArgumentUInt
+                                         , ArgumentInt
+                                         , ArgumentInt
+                                         , ArgumentInt
+                                         ]
+                     , msgSince        = 1
+                     , msgIsDestructor = False
+                     }
+
+evDone :: MessageDesc
+evDone = MessageDesc { msgName         = "done"
+                     , msgSignature    = []
+                     , msgSince        = 2
+                     , msgIsDestructor = False
+                     }
+
+evScale :: MessageDesc
+evScale = MessageDesc { msgName         = "scale"
+                      , msgSignature    = [ ArgumentInt ]
+                      , msgSince        = 2
+                      , msgIsDestructor = False
+                      }
+
+evName :: MessageDesc
+evName = MessageDesc { msgName         = "name"
+                     , msgSignature    = [ ArgumentString NotNull ]
+                     , msgSince        = 4
+                     , msgIsDestructor = False
+                     }
+
+evDescription :: MessageDesc
+evDescription = MessageDesc { msgName         = "description"
+                            , msgSignature    = [ ArgumentString NotNull ]
+                            , msgSince        = 4
+                            , msgIsDestructor = False
+                            }
 
 instance ResourceClass Handle where
   type ResourceEvent   Handle = Event
@@ -24,57 +87,56 @@ instance ResourceClass Handle where
   fromID = Handle
   interface _ = InterfaceDesc { ifName     = "wl_output"
                               , ifVersion  = 4
-                              , ifRequests = [ MessageDesc { msgName         = "release"
-                                                           , msgSignature    = []
-                                                           , msgSince        = 3
-                                                           , msgIsDestructor = True
-                                                           }
-                                             ]
-                              , ifEvents = [ MessageDesc { msgName         = "geometry"
-                                                         , msgSignature    = [ ArgumentInt
-                                                                             , ArgumentInt
-                                                                             , ArgumentInt
-                                                                             , ArgumentInt
-                                                                             , ArgumentInt
-                                                                             , ArgumentString NotNull
-                                                                             , ArgumentString NotNull
-                                                                             , ArgumentInt
-                                                                             ]
-                                                         , msgSince        = 1
-                                                         , msgIsDestructor = False
-                                                         }
-                                           , MessageDesc { msgName         = "mode"
-                                                         , msgSignature    = [ ArgumentUInt
-                                                                             , ArgumentInt
-                                                                             , ArgumentInt
-                                                                             , ArgumentInt
-                                                                             ]
-                                                         , msgSince        = 1
-                                                         , msgIsDestructor = False
-                                                         }
-                                           , MessageDesc { msgName         = "done"
-                                                         , msgSignature    = []
-                                                         , msgSince        = 2
-                                                         , msgIsDestructor = False
-                                                         }
-                                           , MessageDesc { msgName         = "scale"
-                                                         , msgSignature    = [ ArgumentInt ]
-                                                         , msgSince        = 2
-                                                         , msgIsDestructor = False
-                                                         }
-                                           , MessageDesc { msgName         = "name"
-                                                         , msgSignature    = [ ArgumentString NotNull ]
-                                                         , msgSince        = 4
-                                                         , msgIsDestructor = False
-                                                         }
-                                           , MessageDesc { msgName         = "description"
-                                                         , msgSignature    = [ ArgumentString NotNull ]
-                                                         , msgSince        = 4
-                                                         , msgIsDestructor = False
-                                                         }
-                                           ]
+                              , ifRequests = [ reqRelease ]
+                              , ifEvents   = [ evGeometry
+                                             , evMode
+                                             , evDone
+                                             , evScale
+                                             , evName
+                                             , evDescription ]
                               }
 
+  demarshalRequest r 0 = do
+    pure (ReqRelease r)
+  demarshalRequest _ _ = fail "Unknown opcode."
+
+  marshalEvent _ (EvGeometry p) = do
+    marshalInt    (x p)
+    marshalInt    (y p)
+    marshalInt    (physicalWidth p)
+    marshalInt    (physicalHeight p)
+    marshalInt    (fromEnum (subpixel p))
+    marshalString (make p)
+    marshalString (model p)
+    marshalInt    (fromEnum (transform p))
+    pure 0
+  marshalEvent _ (EvMode p) = do
+    marshalUInt (fromBitSet (flags p))
+    marshalInt  (width p)
+    marshalInt  (height p)
+    marshalInt  (refresh p)
+    pure 1
+  marshalEvent _ EvDone = do
+    pure 2
+  marshalEvent _ (EvScale p) = do
+    marshalInt p
+    pure 3
+  marshalEvent _ (EvName p) = do
+    marshalString p
+    pure 4
+  marshalEvent _ (EvDescription p) = do
+    marshalString p
+    pure 5
+
+  requestSignature _ (ReqRelease _) = reqRelease
+
+  eventSignature _ (EvGeometry _)    = evGeometry
+  eventSignature _ (EvMode _)        = evMode
+  eventSignature _  EvDone           = evDone
+  eventSignature _ (EvScale _)       = evScale
+  eventSignature _ (EvName _)        = evName
+  eventSignature _ (EvDescription _) = evDescription
+
 data Subpixel
   = SubpixelUnknown
   | SubpixelNone
@@ -82,6 +144,7 @@ data Subpixel
   | SubpixelHorizontalBgr
   | SubpixelVerticalRgb
   | SubpixelVerticalBgr
+  deriving (Show, Enum)
 
 data Transform
   = TransformNormal
@@ -92,10 +155,24 @@ data Transform
   | TransformFlipped90
   | TransformFlipped180
   | TransformFlipped270
+  deriving (Show, Enum)
+
+data ModeFlags
+  = ModeFlags { current   :: Bool
+              , preferred :: Bool
+              }
+  deriving (Show)
+
+fromBitSet :: ModeFlags -> Word
+fromBitSet _ = 0
 
 data Mode
-  = Mode { current   :: Bool
-         , preferred :: Bool }
+  = Mode { flags   :: ModeFlags
+         , width   :: Int
+         , height  :: Int
+         , refresh :: Int
+         }
+  deriving (Show)
 
 data Geometry
   = Geometry { x              :: Int
@@ -105,13 +182,15 @@ data Geometry
              , subpixel       :: Subpixel
              , make           :: String
              , model          :: String
-             , transform      :: Transform }
+             , transform      :: Transform
+             }
+  deriving (Show)
 
 data Request
   = ReqRelease Handle
   deriving (Typeable, Show)
 
-instance RequestClass Request
+instance RequestClass Request where
 
 data Event
   = EvGeometry    Geometry
@@ -120,3 +199,6 @@ data Event
   | EvName        String
   | EvDescription String
   | EvDone
+  deriving (Typeable, Show)
+
+instance EventClass Event where
diff --git a/protocols/protocols.cabal b/protocols/protocols.cabal
index d90f42e..d071329 100644
--- a/protocols/protocols.cabal
+++ b/protocols/protocols.cabal
@@ -10,6 +10,7 @@ common warnings
 library
     import:           warnings
     build-depends:    base ^>=4.18.2.1,
+                      hashable,
                       highway-wayland
     default-language: Haskell2010
     exposed-modules:  Wayland.Protocols.Core.WLOutput,
diff --git a/wayland/Wayland/Server.hs b/wayland/Wayland/Server.hs
index 7d60512..77dea63 100644
--- a/wayland/Wayland/Server.hs
+++ b/wayland/Wayland/Server.hs
@@ -6,13 +6,17 @@
 {-# LANGUAGE UndecidableInstances #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE FlexibleContexts #-}
 
 module Wayland.Server
   ( Request(..)
   , ObjectID
   , Global
+  , ArgumentMarshaller(..)
+  , ArgumentDemarshaller(..)
   , DisplayM(..)
   , ResourceClass(..)
+  , EventClass
   , RequestClass
   , InterfaceDesc(..)
   , MessageDesc(..)
@@ -36,12 +40,12 @@ import Data.Kind (Type)
 import Control.Monad.State.Strict (StateT, MonadState(..), MonadIO(..), runStateT)
 import Lens.Micro.Mtl.Internal (Zoom(..), Zoomed)
 import Lens.Micro.TH (makeLenses)
-import Lens.Micro.Mtl ((%=), use)
+import Lens.Micro.Mtl ((%=), use, (<<%=))
 import qualified Wayland.Server.System as Sys
 import Control.Monad.Trans (MonadTrans(..))
 import Foreign.C (peekCString, newCString)
 import Foreign.C.Types (CInt)
-import Foreign (Ptr, nullPtr, new)
+import Foreign (Ptr, nullPtr, new, newStablePtr, castStablePtrToPtr, castPtrToStablePtr, deRefStablePtr, freeStablePtr, Storable (..), Int32, castPtr, free, mallocArray0)
 import Data.IORef (IORef, newIORef, writeIORef, readIORef)
 import Control.Monad.Reader (ReaderT, MonadReader (..), runReaderT)
 import Control.Exception (bracket)
@@ -51,11 +55,24 @@ import Data.Maybe (isJust)
 import qualified Data.Map as M
 import Foreign.Marshal (newArray)
 import Data.Word (Word32)
+import System.Mem.StableName (StableName, makeStableName)
+import Data.Hashable (Hashable(..))
+import Foreign.Ptr (plusPtr)
 
 data Global = Global
 
-data ObjectID = ObjectID
-  deriving (Show, Eq, Ord)
+-- IORef set to nullPtr once destroyed.
+data ObjectID = ObjectID (StableName (IORef Sys.WLResource)) (IORef Sys.WLResource)
+  deriving (Eq)
+
+instance Ord ObjectID where
+  (ObjectID nameA _) <= (ObjectID nameB _) = hash nameA <= hash nameB
+
+instance Hashable ObjectID where
+  hashWithSalt s (ObjectID name _) = hashWithSalt s name
+
+instance Show ObjectID where
+  show (ObjectID name _) = "ObjectID " ++ show (hash name)
 
 data Nullability
   = AllowNull
@@ -91,6 +108,8 @@ data InterfaceDesc
 
 class (Typeable r, Show r) => RequestClass r where
 
+class (Typeable e, Show e) => EventClass e where
+
 data Request = forall a. RequestClass a => Request a
 
 newtype DisplayM s a = DisplayM { runDisplayM :: StateT s (StateT DisplayState (ReaderT Display IO)) a }
@@ -112,12 +131,36 @@ data DisplayState
 
 makeLenses ''DisplayState
 
-class Typeable r => ResourceClass r where
+class (Typeable r, RequestClass (ResourceRequest r), EventClass (ResourceEvent r)) => ResourceClass r where
   type ResourceRequest r :: Type
   type ResourceEvent   r :: Type
   objectID  :: r        -> ObjectID
   fromID    :: ObjectID -> r
   interface :: Proxy r  -> InterfaceDesc
+  marshalEvent     :: ArgumentMarshaller m   => Proxy r -> ResourceEvent r -> m Int
+  demarshalRequest :: ArgumentDemarshaller m => r -> Int -> m (ResourceRequest r)
+  eventSignature   :: Proxy r -> ResourceEvent r   -> MessageDesc
+  requestSignature :: Proxy r -> ResourceRequest r -> MessageDesc
+
+class (Monad m, MonadFail m) => ArgumentMarshaller m where
+  marshalInt    :: Int                  -> m ()
+  marshalUInt   :: Word                 -> m ()
+  marshalFixed  :: Float                -> m ()
+  marshalString :: String               -> m ()
+  marshalObject :: ResourceClass r => r -> m ()
+  marshalNewID  :: ResourceClass r => r -> m ()
+  marshalArray  :: Storable a => [a]    -> m ()
+  marshalFD     :: Int32                -> m ()
+
+class (Monad m, MonadFail m) => ArgumentDemarshaller m where
+  demarshalInt    :: m Int
+  demarshalUInt   :: m Word
+  demarshalFixed  :: m Float
+  demarshalString :: m String
+  demarshalObject :: ResourceClass r => m r
+  demarshalNewID  :: ResourceClass r => m r
+  demarshalArray  :: Storable a => m [a]
+  demarshalFD     :: m Int32
 
 instance Show Request where
   show (Request r) = show r
@@ -173,25 +216,38 @@ processRequests h = do
   put stateAfter
   liftDisplayState $ put displayStateAfter
 
-sendEvent :: ResourceClass r => r -> ResourceEvent r -> DisplayM s ()
-sendEvent _ _ = pure () -- TODO
-
-flushEvents :: DisplayM s ()
-flushEvents = pure () -- TODO
-
-destroyResource :: ResourceClass r => r -> DisplayM s ()
-destroyResource _ = pure () -- TODO
-
-registerGlobal :: forall r req s. ResourceClass r => RequestClass req => (r -> req) -> Int -> DisplayM s Global
-registerGlobal mkReq version = do
+registerGlobal :: forall r bindReq unbindReq s. ResourceClass r => RequestClass bindReq => RequestClass unbindReq => (r -> bindReq) -> (r -> unbindReq) -> Int -> DisplayM s Global
+registerGlobal mkBindReq mkUnbindReq version = do
   disp <- getDisplay
   iface <- getInterface (Proxy :: Proxy r)
+  let dispatcher :: Ptr () -> Sys.WLResource -> Word32 -> Ptr Sys.WLMessage -> Ptr Sys.WLArgument -> IO CInt
+      dispatcher _ res opcode _ _ = do
+        handlePtr <- castPtrToStablePtr <$> Sys.wlResourceGetUserData res
+        objID@(ObjectID _ _) <- deRefStablePtr handlePtr
+        putStrLn $ "Handling request " ++ show opcode ++ " for " ++ show objID
+        -- TODO: Handle request
+        pure 0
+  let destroy :: Sys.WLResource -> IO ()
+      destroy res = do
+        handlePtr <- castPtrToStablePtr <$> Sys.wlResourceGetUserData res
+        objID@(ObjectID _ handle) <- deRefStablePtr handlePtr
+        writeIORef handle (Sys.WLResource nullPtr)
+        freeStablePtr handlePtr
+        let req = mkUnbindReq (fromID objID)
+        runRequest disp (Request req)
+        pure ()
   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)
+      createObject client _ ver protID = do
+        res <- Sys.wlResourceCreate client iface (fromIntegral ver) protID
+        handle <- newIORef res
+        name <- makeStableName handle
+        let objID = ObjectID name handle
+        handlePtr <- newStablePtr objID
+        dis <- Sys.wrapWLDispatcherFunc dispatcher
+        des <- Sys.wrapWLResourceDestroyFunc destroy
+        -- TODO: Free functions
+        Sys.wlResourceSetDispatcher res dis nullPtr (castStablePtrToPtr handlePtr) des
+        let req = mkBindReq (fromID objID)
         runRequest disp (Request req)
         pure ()
   liftIO $ do
@@ -282,3 +338,80 @@ getInterface p = do
     Nothing  -> do ptr <- wrapInterface (interface p)
                    liftDisplayState $ typeInterfaces %= M.insert (typeRep p) ptr
                    pure ptr
+
+data ArgumentIteratorState
+  = ArgumentIteratorState { _argNext          :: !(Ptr Sys.WLArgument)
+                          , _argRemaining     :: !Int
+                          , _allocatedBuffers :: ![Ptr ()]
+                          }
+  deriving (Show)
+
+makeLenses ''ArgumentIteratorState
+
+newtype ArgumentIterator a = ArgumentIterator { runArgumentIterator :: StateT ArgumentIteratorState IO a }
+  deriving (Functor, Applicative, Monad, MonadFail, MonadState ArgumentIteratorState, MonadIO)
+
+advanceIterator :: ArgumentIterator (Ptr Sys.WLArgument)
+advanceIterator = do
+  next      <- argNext      <<%= \p -> plusPtr p (sizeOf (undefined :: Sys.WLArgument))
+  remaining <- argRemaining <<%= (+(-1))
+  when (remaining == 0) (fail "Out of range for argument")
+  pure next
+
+getObjectForHandle :: ResourceClass r => r -> IO (Ptr a)
+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)
+
+instance ArgumentMarshaller ArgumentIterator 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))
+  marshalString v = do
+    arg <- advanceIterator
+    str <- liftIO $ newCString v
+    allocatedBuffers %= (castPtr str:)
+    liftIO $ Sys.wlArgumentSetString str arg
+  marshalObject v = do
+    arg <- advanceIterator
+    obj <- liftIO $ getObjectForHandle v
+    liftIO $ Sys.wlArgumentSetObject obj arg
+  marshalNewID v = do
+    arg <- advanceIterator
+    obj <- liftIO $ getObjectForHandle v
+    liftIO $ Sys.wlArgumentSetObject obj arg
+  marshalArray v = do
+    arg <- advanceIterator
+    let len = fromIntegral $ length v * sizeOf (head v)
+    buf <- liftIO $ newArray v
+    arr <- liftIO $ new $ Sys.WLArray { Sys.arrSize  = len
+                                      , Sys.arrAlloc = len
+                                      , Sys.arrData  = castPtr buf
+                                      }
+    allocatedBuffers %= \p -> castPtr buf:castPtr arr:p
+    liftIO $ Sys.wlArgumentSetArray arr arg
+
+sendEvent :: forall r s. ResourceClass r => r -> ResourceEvent r -> DisplayM s ()
+sendEvent res e = liftIO $ do
+  let params = msgSignature (eventSignature (Proxy :: Proxy r) e)
+  ptr <- getObjectForHandle res
+  buffer <- mallocArray0 (length params)
+  let s = ArgumentIteratorState { _argNext          = buffer
+                                , _argRemaining     = length params
+                                , _allocatedBuffers = [castPtr buffer]
+                                }
+  (opcode, s') <- runStateT (runArgumentIterator (marshalEvent (Proxy :: Proxy r) e)) s
+  Sys.wlResourcePostEventArray (Sys.WLResource ptr) (fromIntegral opcode) buffer
+  mapM_ free (_allocatedBuffers s')
+
+flushEvents :: DisplayM s ()
+flushEvents = do
+  disp <- getDisplay
+  liftIO $ Sys.wlDisplayFlushClients (display disp)
+
+destroyResource :: ResourceClass r => r -> DisplayM s ()
+destroyResource r = liftIO $ do
+  ptr <- getObjectForHandle r
+  Sys.wlResourceDestroy (Sys.WLResource ptr)
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 ()
diff --git a/wayland/wayland.cabal b/wayland/wayland.cabal
index c54a9fd..ee0f9a9 100644
--- a/wayland/wayland.cabal
+++ b/wayland/wayland.cabal
@@ -12,6 +12,7 @@ library
     build-depends:     base ^>=4.18.2.1,
                        mtl,
                        containers,
+                       hashable,
                        microlens,
                        microlens-mtl,
                        microlens-th