refactor Wayland.Server.System

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 ()