refactor Wayland.Server.System

2 files changed, 202 insertions, 155 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
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 ()