diff options
Diffstat (limited to 'wayland/Wayland/Server.hs')
| -rw-r--r-- | wayland/Wayland/Server.hs | 60 |
1 files changed, 35 insertions, 25 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 |