summaryrefslogtreecommitdiff
path: root/wayland/Wayland/Server
diff options
context:
space:
mode:
Diffstat (limited to 'wayland/Wayland/Server')
-rw-r--r--wayland/Wayland/Server/System.hsc297
1 files changed, 167 insertions, 130 deletions
diff --git a/wayland/Wayland/Server/System.hsc b/wayland/Wayland/Server/System.hsc
index 0f68578..b01611e 100644
--- a/wayland/Wayland/Server/System.hsc
+++ b/wayland/Wayland/Server/System.hsc
@@ -1,49 +1,24 @@
{-# LANGUAGE ForeignFunctionInterface #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
+-- |
+-- Module : Wayland.Server.System
+-- Description: Bindings for the system-provided libwayland library.
+--
+-- libwayland is used to handle socket creation, implementing the protocol, and the event loop. We do not use the
+-- interfaces or bindings provided by it but only its primitives like wl_resource in combination with our own code
+-- generator which generates the interfaces and (de-)marshals all arguments and opcodes. This is done to keep the amount
+-- of C interop small.
module Wayland.Server.System where
#include <wayland-server.h>
-import Foreign (FunPtr, Ptr, Storable(..), Int32, castPtr)
-import Foreign.C (CString, CInt(..), CSize)
+import Foreign (FunPtr, Ptr, Int32, Storable(..), castPtr)
+import Foreign.C (CString, CSize, CInt(..))
import Data.Word (Word32)
-data WLMessage
- = WLMessage { msgName :: CString
- , msgSignature :: CString
- , msgTypes :: Ptr (Ptr WLInterface)
- }
- deriving (Show)
-
-data WLInterface
- = WLInterface { ifName :: CString
- , ifVersion :: CInt
- , ifMethodCount :: CInt
- , ifMethods :: Ptr WLMessage
- , ifEventCount :: CInt
- , ifEvents :: Ptr WLMessage
- }
- deriving (Show)
-
-newtype WLFixed = WLFixed #{type wl_fixed_t}
- deriving (Show)
-
-data WLArray
- = WLArray { arrSize :: CSize
- , arrAlloc :: CSize
- , arrData :: Ptr ()
- }
- deriving (Show)
-
-data WLArgument = WLArgument
- deriving (Show)
-
-newtype WLDisplay = WLDisplay (Ptr WLDisplay) deriving (Show)
-newtype WLEventLoop = WLEventLoop (Ptr WLEventLoop) deriving (Show)
-newtype WLEventSource = WLEventSource (Ptr WLEventSource) deriving (Show)
-newtype WLGlobal = WLGlobal (Ptr WLGlobal) deriving (Show)
-newtype WLClient = WLClient (Ptr WLClient) deriving (Show)
-newtype WLResource = WLResource (Ptr WLResource) deriving (Show)
+-- * Callback Types
type WLEventLoopSignalFunc = CInt -> Ptr () -> IO CInt
type WLGlobalBindFunc = WLClient -> Ptr () -> Word32 -> Word32 -> IO ()
@@ -62,95 +37,16 @@ foreign import ccall "wrapper"
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 ()
+-- * Primitive Types
-foreign import ccall "wl_display_flush_clients"
- wlDisplayFlushClients :: WLDisplay -> IO ()
-
-foreign import ccall "wl_display_add_socket_auto"
- wlDisplayAddSocketAuto :: WLDisplay -> IO CString
-
-foreign import ccall "wl_display_run"
- wlDisplayRun :: WLDisplay -> IO ()
-
-foreign import ccall "wl_display_terminate"
- wlDisplayTerminate :: WLDisplay -> IO ()
+-- ** wl_message
-foreign import ccall "wl_display_get_event_loop"
- wlDisplayGetEventLoop :: WLDisplay -> IO WLEventLoop
-
-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
-
-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}
-
-wlArgumentGetUInt :: Ptr WLArgument -> IO Word32
-wlArgumentGetUInt = #{peek union wl_argument, u}
-
-wlArgumentGetFixed :: Ptr WLArgument -> IO WLFixed
-wlArgumentGetFixed = #{peek union wl_argument, f}
-
-wlArgumentGetString :: Ptr WLArgument -> IO CString
-wlArgumentGetString = #{peek union wl_argument, s}
-
-wlArgumentGetObject :: Ptr WLArgument -> IO (Ptr ())
-wlArgumentGetObject = #{peek union wl_argument, o}
-
-wlArgumentGetNewID :: Ptr WLArgument -> IO Word32
-wlArgumentGetNewID = #{peek union wl_argument, n}
-
-wlArgumentGetArray :: Ptr WLArgument -> IO (Ptr WLArray)
-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
+data WLMessage
+ = WLMessage { msgName :: CString
+ , msgSignature :: CString
+ , msgTypes :: Ptr (Ptr WLInterface)
+ }
+ deriving (Show)
instance Storable WLMessage where
sizeOf _ = #{size struct wl_message}
@@ -169,6 +65,18 @@ instance Storable WLMessage where
#{poke struct wl_message, types} p $ msgTypes m
return ()
+-- ** wl_interface
+
+data WLInterface
+ = WLInterface { ifName :: CString
+ , ifVersion :: CInt
+ , ifMethodCount :: CInt
+ , ifMethods :: Ptr WLMessage
+ , ifEventCount :: CInt
+ , ifEvents :: Ptr WLMessage
+ }
+ deriving (Show)
+
instance Storable WLInterface where
sizeOf _ = #{size struct wl_interface}
alignment _ = #{alignment struct wl_interface}
@@ -195,6 +103,26 @@ instance Storable WLInterface where
#{poke struct wl_interface, events} p $ ifEvents m
return ()
+-- ** wl_fixed
+
+newtype WLFixed = WLFixed #{type wl_fixed_t}
+ deriving (Show)
+
+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
+
+-- ** wl_array
+
+data WLArray
+ = WLArray { arrSize :: CSize
+ , arrAlloc :: CSize
+ , arrData :: Ptr ()
+ }
+ deriving (Show)
+
instance Storable WLArray where
sizeOf _ = #{size struct wl_array}
alignment _ = #{alignment struct wl_array}
@@ -212,14 +140,123 @@ instance Storable WLArray where
#{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
+-- ** wl_argument
+
+-- Accessed through the wlArgumentPeek* and wlArgumentPoke* methods as the actual data type is unknown just from looking
+-- at the union.
+data WLArgument = WLArgument
+ deriving (Show)
instance Storable WLArgument where
sizeOf _ = #{size union wl_argument}
alignment _ = #{alignment union wl_argument}
peek _ = pure WLArgument
poke _ _ = pure ()
+
+wlArgumentPeekInt :: Ptr WLArgument -> IO Int32
+wlArgumentPeekInt = #{peek union wl_argument, i}
+wlArgumentPeekUInt :: Ptr WLArgument -> IO Word32
+wlArgumentPeekUInt = #{peek union wl_argument, u}
+wlArgumentPeekFixed :: Ptr WLArgument -> IO WLFixed
+wlArgumentPeekFixed = #{peek union wl_argument, f}
+wlArgumentPeekString :: Ptr WLArgument -> IO CString
+wlArgumentPeekString = #{peek union wl_argument, s}
+wlArgumentPeekObject :: Ptr WLArgument -> IO WLResource
+wlArgumentPeekObject = #{peek union wl_argument, o}
+wlArgumentPeekNewID :: Ptr WLArgument -> IO Word32
+wlArgumentPeekNewID = #{peek union wl_argument, n}
+wlArgumentPeekArray :: Ptr WLArgument -> IO (Ptr WLArray)
+wlArgumentPeekArray = #{peek union wl_argument, a}
+wlArgumentPeekFD :: Ptr WLArgument -> IO Int32
+wlArgumentPeekFD = #{peek union wl_argument, h}
+
+wlArgumentPokeInt :: Ptr WLArgument -> Int32 -> IO ()
+wlArgumentPokeInt = #{poke union wl_argument, i}
+wlArgumentPokeUInt :: Ptr WLArgument -> Word32 -> IO ()
+wlArgumentPokeUInt = #{poke union wl_argument, u}
+wlArgumentPokeFixed :: Ptr WLArgument -> WLFixed -> IO ()
+wlArgumentPokeFixed = #{poke union wl_argument, f}
+wlArgumentPokeString :: Ptr WLArgument -> CString -> IO ()
+wlArgumentPokeString = #{poke union wl_argument, s}
+wlArgumentPokeObject :: Ptr WLArgument -> WLResource -> IO ()
+wlArgumentPokeObject = #{poke union wl_argument, o}
+wlArgumentPokeNewID :: Ptr WLArgument -> Word32 -> IO ()
+wlArgumentPokeNewID = #{poke union wl_argument, n}
+wlArgumentPokeArray :: Ptr WLArgument -> Ptr WLArray -> IO ()
+wlArgumentPokeArray = #{poke union wl_argument, a}
+wlArgumentPokeFD :: Ptr WLArgument -> Int32 -> IO ()
+wlArgumentPokeFD = #{poke union wl_argument, h}
+
+-- * Opaque Types
+
+-- ** wl_display
+
+newtype WLDisplay = WLDisplay (Ptr WLDisplay)
+ deriving (Show, Eq, Storable)
+
+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
+
+foreign import ccall "wl_display_run"
+ wlDisplayRun :: WLDisplay -> IO ()
+
+foreign import ccall "wl_display_terminate"
+ wlDisplayTerminate :: WLDisplay -> IO ()
+
+foreign import ccall "wl_display_get_event_loop"
+ wlDisplayGetEventLoop :: WLDisplay -> IO WLEventLoop
+
+-- ** wl_event_loop
+
+newtype WLEventLoop = WLEventLoop (Ptr WLEventLoop)
+ deriving (Show, Eq, Storable)
+
+foreign import ccall "wl_event_loop_add_signal"
+ wlEventLoopAddSignal :: WLEventLoop -> CInt -> FunPtr WLEventLoopSignalFunc -> Ptr () -> IO WLEventSource
+
+-- ** wl_event_source
+
+newtype WLEventSource = WLEventSource (Ptr WLEventSource)
+ deriving (Show, Eq, Storable)
+
+-- ** wl_global
+
+newtype WLGlobal = WLGlobal (Ptr WLGlobal)
+ deriving (Show, Eq, Storable)
+
+foreign import ccall "wl_global_create"
+ wlGlobalCreate :: WLDisplay -> Ptr WLInterface -> CInt -> Ptr () -> FunPtr WLGlobalBindFunc -> IO WLGlobal
+
+-- ** wl_client
+
+newtype WLClient = WLClient (Ptr WLClient)
+ deriving (Show, Eq, Storable)
+
+-- ** wl_resource
+
+newtype WLResource = WLResource (Ptr WLResource)
+ deriving (Show, Eq, Storable)
+
+foreign import ccall "wl_resource_create"
+ wlResourceCreate :: WLClient -> Ptr WLInterface -> CInt -> Word32 -> IO WLResource
+
+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 ()
generated by cgit v1.3.1 (git 2.54.0) at 2026-11-10 12:11:18 +0000