From 049dfc4dc5341f6d0e0015dccbb54352351e9e14 Mon Sep 17 00:00:00 2001 From: Hannes Schulze Date: Sun, 4 Aug 2024 20:45:24 +0200 Subject: wrap interfaces --- wayland/Wayland/Server.hs | 173 ++++++++++++++++++++++++++++---------- wayland/Wayland/Server/System.hsc | 2 + wayland/wayland.cabal | 4 +- 3 files changed, 135 insertions(+), 44 deletions(-) (limited to 'wayland') diff --git a/wayland/Wayland/Server.hs b/wayland/Wayland/Server.hs index 76b9ff4..b0c5b89 100644 --- a/wayland/Wayland/Server.hs +++ b/wayland/Wayland/Server.hs @@ -4,6 +4,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TemplateHaskell #-} module Wayland.Server ( Request(..) @@ -29,27 +30,25 @@ module Wayland.Server , requestTermination ) where -import Data.Typeable (Typeable, Proxy, cast) +import Data.Typeable (Typeable, Proxy, cast, TypeRep, typeRep) import Data.Kind (Type) import Control.Monad.State.Strict (StateT, MonadState(..), MonadIO(..), runStateT) import Lens.Micro.Mtl.Internal (Zoom(..), Zoomed) -import Wayland.Server.System +import Lens.Micro.TH (makeLenses) +import Lens.Micro.Mtl ((%=), use) +import qualified Wayland.Server.System as Sys import Control.Monad.Trans (MonadTrans(..)) -import Foreign.C (peekCString) +import Foreign.C (peekCString, newCString) import Foreign.C.Types (CInt) -import Foreign (nullPtr) +import Foreign (Ptr, nullPtr, new) import Data.IORef (IORef, newIORef, writeIORef, readIORef) import Control.Monad.Reader (ReaderT, MonadReader (..), runReaderT) import Control.Exception (bracket) import Data.Functor (($>)) - -type RequestHandler s = Request -> DisplayM s () -type EventLoopHandler = Request -> IO () - -data Display - = Display { display :: !WLDisplay - , activeEventLoop :: !(IORef (Maybe EventLoopHandler)) - } +import Control.Monad (when) +import Data.Maybe (isJust) +import qualified Data.Map as M +import Foreign.Marshal (newArray) data Global = Global @@ -59,25 +58,26 @@ newtype ObjectID = ObjectID String data Nullability = AllowNull | NotNull + deriving (Show, Eq, Ord) data ArgumentDesc = ArgumentInt | ArgumentUInt | ArgumentFixed | ArgumentString !Nullability - | ArgumentObject !Nullability - | ArgumentNewID + | ArgumentObject !Nullability !InterfaceDesc + | ArgumentNewID !InterfaceDesc | ArgumentArray | ArgumentFD + deriving (Show, Eq, Ord) data MessageDesc = MessageDesc { msgName :: !String , msgSignature :: ![ArgumentDesc] , msgSince :: !Int , msgIsDestructor :: !Bool - , msgCreatedInterface :: !(Maybe InterfaceDesc) - , msgArgumentInterface :: ![InterfaceDesc] } + deriving (Show, Eq, Ord) data InterfaceDesc = InterfaceDesc { ifName :: !String @@ -85,62 +85,92 @@ data InterfaceDesc , ifRequests :: ![MessageDesc] , ifEvents :: ![MessageDesc] } + deriving (Show, Eq, Ord) + +class (Typeable r, Show r) => RequestClass r where + +data Request = forall a. RequestClass a => Request a + +newtype DisplayM s a = DisplayM { runDisplayM :: StateT s (StateT DisplayState (ReaderT Display IO)) a } + deriving (Functor, Applicative, Monad, MonadIO, MonadState s, MonadFail) -class ResourceClass r where +type RequestHandler s = Request -> DisplayM s () + +newtype EventLoop = EventLoop { handleEvent :: Request -> IO () } + +data Display + = Display { display :: !Sys.WLDisplay + , activeEventLoop :: !(IORef (Maybe EventLoop)) + } + +data DisplayState + = DisplayState { _typeInterfaces :: !(M.Map TypeRep (Ptr Sys.WLInterface)) + , _nativeInterfaces :: !(M.Map InterfaceDesc (Ptr Sys.WLInterface)) + } + +makeLenses ''DisplayState + +class Typeable r => ResourceClass r where type ResourceRequest r :: Type type ResourceEvent r :: Type - objectID :: r -> ObjectID + objectID :: r -> ObjectID interface :: Proxy r -> InterfaceDesc -class (Typeable r, Show r) => RequestClass r where - -data Request = forall a. RequestClass a => Request a instance Show Request where show (Request r) = show r -newtype DisplayM s a = DisplayM { runDisplayM :: StateT s (ReaderT Display IO) a } - deriving (Functor, Applicative, Monad, MonadIO, MonadState s) -type instance Zoomed (DisplayM s) = Zoomed (StateT s (ReaderT Display IO)) +type instance Zoomed (DisplayM s) = Zoomed (StateT s (StateT DisplayState (ReaderT Display IO))) instance Zoom (DisplayM s) (DisplayM t) s t where zoom l (DisplayM m) = DisplayM (zoom l m) getDisplay :: DisplayM s Display -getDisplay = DisplayM $ lift ask +getDisplay = DisplayM $ lift $ lift ask + +liftDisplayState :: StateT DisplayState (ReaderT Display IO) a -> DisplayM s a +liftDisplayState m = DisplayM $ lift m fromRequest :: Typeable a => Request -> Maybe a fromRequest (Request x) = cast x withDisplay :: s -> DisplayM s a -> IO (a, s) -withDisplay initialState f = bracket wlDisplayCreate wlDisplayDestroy $ \sysDisp -> do +withDisplay initialState f = bracket Sys.wlDisplayCreate Sys.wlDisplayDestroy $ \sysDisp -> do eventLoop <- newIORef Nothing let disp = Display { display = sysDisp - , activeEventLoop = eventLoop } - runReaderT (runStateT (runDisplayM f) initialState) disp + , activeEventLoop = eventLoop + } + dispState = DisplayState { _typeInterfaces = M.empty + , _nativeInterfaces = M.empty + } + (res, _) <- runReaderT (runStateT (runStateT (runDisplayM f) initialState) dispState) disp + pure res bindSocket :: DisplayM s String bindSocket = do disp <- getDisplay - name <- liftIO $ wlDisplayAddSocketAuto (display disp) + name <- liftIO $ Sys.wlDisplayAddSocketAuto (display disp) liftIO $ peekCString name processRequests :: RequestHandler s -> DisplayM s () processRequests h = do disp <- getDisplay stateBefore <- get - stateRef <- liftIO $ newIORef stateBefore + displayStateBefore <- liftDisplayState get + stateRef <- liftIO $ newIORef (stateBefore, displayStateBefore) let handler :: Request -> IO () handler r = do - s <- readIORef stateRef - (_, s') <- runReaderT (runStateT (runDisplayM (h r)) s) disp - writeIORef stateRef s' - pure () - liftIO $ writeIORef (activeEventLoop disp) (Just handler) - liftIO $ wlDisplayRun (display disp) - stateAfter <- liftIO $ readIORef stateRef + (s, ds) <- readIORef stateRef + ((_, s'), ds') <- runReaderT (runStateT (runStateT (runDisplayM (h r)) s) ds) disp + writeIORef stateRef (s', ds') + loop <- liftIO $ readIORef (activeEventLoop disp) + when (isJust loop) (fail "Cannot start an event loop from within an event handler.") + liftIO $ writeIORef (activeEventLoop disp) (Just (EventLoop handler)) + liftIO $ Sys.wlDisplayRun (display disp) + (stateAfter, displayStateAfter) <- liftIO $ readIORef stateRef put stateAfter + liftDisplayState $ put displayStateAfter sendEvent :: ResourceClass r => r -> ResourceEvent r -> DisplayM s () sendEvent _ _ = undefined @@ -161,18 +191,75 @@ runRequest :: Display -> Request -> IO () runRequest disp r = do loop <- readIORef (activeEventLoop disp) case loop of - Just handler -> handler r + 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 r sig = do disp <- getDisplay - loop <- liftIO $ wlDisplayGetEventLoop (display disp) - func <- liftIO $ wrapWLEventLoopSignalFunc $ \_ _ -> runRequest disp (Request r) $> 0 - _ <- liftIO $ wlEventLoopAddSignal loop sig func nullPtr - pure () + liftIO $ do + loop <- Sys.wlDisplayGetEventLoop (display disp) + func <- Sys.wrapWLEventLoopSignalFunc $ \_ _ -> runRequest disp (Request r) $> 0 + _ <- Sys.wlEventLoopAddSignal loop sig func nullPtr + -- TODO: Free func + pure () requestTermination :: DisplayM s () requestTermination = do disp <- getDisplay - liftIO $ wlDisplayTerminate (display disp) + liftIO $ Sys.wlDisplayTerminate (display disp) + +wrapInterface :: InterfaceDesc -> DisplayM s (Ptr Sys.WLInterface) +wrapInterface i = do + let mkArgumentType :: ArgumentDesc -> DisplayM s (Ptr Sys.WLInterface) + mkArgumentType (ArgumentObject _ a) = wrapInterface a + mkArgumentType (ArgumentNewID a) = wrapInterface a + mkArgumentType _ = pure nullPtr + let mkArgument :: ArgumentDesc -> String + mkArgument ArgumentInt = "i" + mkArgument ArgumentUInt = "u" + mkArgument ArgumentFixed = "f" + mkArgument (ArgumentString NotNull) = "s" + mkArgument (ArgumentString AllowNull) = "?s" + mkArgument (ArgumentObject NotNull _) = "o" + mkArgument (ArgumentObject AllowNull _) = "?o" + mkArgument (ArgumentNewID _) = "n" + mkArgument ArgumentArray = "a" + mkArgument ArgumentFD = "h" + let mkMessage :: MessageDesc -> DisplayM s Sys.WLMessage + mkMessage m = do + name <- liftIO $ newCString (msgName m) + signature <- liftIO $ newCString (show (msgSince m) ++ (msgSignature m >>= mkArgument)) + types <- mapM mkArgumentType (msgSignature m) >>= liftIO . newArray + pure $ Sys.WLMessage { Sys.msgName = name + , Sys.msgSignature = signature + , Sys.msgTypes = types + } + let mkInterface :: DisplayM s (Ptr Sys.WLInterface) + mkInterface = do + name <- liftIO $ newCString (ifName i) + methods <- mapM mkMessage (ifRequests i) >>= liftIO . newArray + events <- mapM mkMessage (ifEvents i) >>= liftIO . newArray + liftIO $ new $ Sys.WLInterface { Sys.ifName = name + , Sys.ifVersion = fromIntegral $ ifVersion i + , Sys.ifMethodCount = fromIntegral $ length (ifRequests i) + , Sys.ifMethods = methods + , Sys.ifEventCount = fromIntegral $ length (ifEvents i) + , Sys.ifEvents = events + } + existing <- liftDisplayState $ use nativeInterfaces + case M.lookup i existing of + Just ptr -> pure ptr + Nothing -> do ptr <- mkInterface + -- TODO: Free ptr + liftDisplayState $ nativeInterfaces %= M.insert i ptr + pure ptr + +getInterface :: ResourceClass r => Proxy r -> DisplayM s (Ptr Sys.WLInterface) +getInterface p = do + existing <- liftDisplayState $ use typeInterfaces + case M.lookup (typeRep p) existing of + Just ptr -> pure ptr + Nothing -> do ptr <- wrapInterface (interface p) + liftDisplayState $ typeInterfaces %= M.insert (typeRep p) ptr + pure ptr diff --git a/wayland/Wayland/Server/System.hsc b/wayland/Wayland/Server/System.hsc index 60940ce..f758a65 100644 --- a/wayland/Wayland/Server/System.hsc +++ b/wayland/Wayland/Server/System.hsc @@ -12,6 +12,7 @@ data WLMessage , msgSignature :: CString , msgTypes :: Ptr (Ptr WLInterface) } + deriving (Show) data WLInterface = WLInterface { ifName :: CString @@ -21,6 +22,7 @@ data WLInterface , ifEventCount :: CInt , ifEvents :: Ptr WLMessage } + deriving (Show) newtype WLDisplay = WLDisplay (Ptr WLDisplay) newtype WLEventLoop = WLEventLoop (Ptr WLEventLoop) diff --git a/wayland/wayland.cabal b/wayland/wayland.cabal index 4409b98..c54a9fd 100644 --- a/wayland/wayland.cabal +++ b/wayland/wayland.cabal @@ -11,8 +11,10 @@ library import: warnings build-depends: base ^>=4.18.2.1, mtl, + containers, microlens, - microlens-mtl + microlens-mtl, + microlens-th default-language: Haskell2010 exposed-modules: Wayland.Server, Wayland.Server.System -- cgit v1.3.1