diff options
Diffstat (limited to 'wayland/Wayland')
| -rw-r--r-- | wayland/Wayland/Server.hs | 80 | ||||
| -rw-r--r-- | wayland/Wayland/Server/System.hsc | 92 |
2 files changed, 157 insertions, 15 deletions
diff --git a/wayland/Wayland/Server.hs b/wayland/Wayland/Server.hs index 9162d5e..0b0b6ea 100644 --- a/wayland/Wayland/Server.hs +++ b/wayland/Wayland/Server.hs @@ -10,7 +10,11 @@ module Wayland.Server , ObjectID , Global , DisplayM(..) - , Resource(..) + , ResourceClass(..) + , InterfaceDesc(..) + , MessageDesc(..) + , ArgumentDesc(..) + , Nullability(..) , fromRequest , withDisplay , bindSocket @@ -22,22 +26,58 @@ module Wayland.Server , unregisterGlobal ) where -import Data.Typeable (Typeable, cast) +import Data.Typeable (Typeable, Proxy, cast) import Data.Kind (Type) -import Control.Monad.State.Strict (StateT, MonadState(..), MonadIO(..)) +import Control.Monad.State.Strict (StateT, MonadState(..), MonadIO(..), runStateT, gets) import Lens.Micro.Mtl.Internal (Zoom(..), Zoomed) +import Wayland.Server.System +import Control.Monad.Trans (MonadTrans(..)) +import Foreign.C (peekCString) data DisplayState + = DisplayState { display :: WLDisplay + } -data Global +data Global = Global newtype ObjectID = ObjectID String deriving (Show, Eq, Ord) -class Resource r where +data Nullability + = AllowNull + | NotNull + +data ArgumentDesc + = ArgumentInt + | ArgumentUInt + | ArgumentFixed + | ArgumentString !Nullability + | ArgumentObject !Nullability + | ArgumentNewID + | ArgumentArray + | ArgumentFD + +data MessageDesc + = MessageDesc { msgName :: !String + , msgSignature :: ![ArgumentDesc] + , msgSince :: !Int + , msgIsDestructor :: !Bool + , msgCreatedInterface :: !(Maybe InterfaceDesc) + , msgArgumentInterface :: ![InterfaceDesc] + } + +data InterfaceDesc + = InterfaceDesc { ifName :: !String + , ifVersion :: !Int + , ifRequests :: ![MessageDesc] + , ifEvents :: ![MessageDesc] + } + +class ResourceClass r where type ResourceRequest r :: Type type ResourceEvent r :: Type - objectID :: r -> ObjectID + objectID :: r -> ObjectID + interface :: Proxy r -> InterfaceDesc data Request = forall a. Typeable a => Request a @@ -52,26 +92,36 @@ instance Zoom (DisplayM s) (DisplayM t) s t where fromRequest :: Typeable a => Request -> Maybe a fromRequest (Request x) = cast x -withDisplay :: s -> DisplayM s a -> IO (s, a) -withDisplay _ _ = undefined +withDisplay :: s -> DisplayM s a -> IO (a, s) +withDisplay initialState f = do + disp <- wlDisplayCreate + let dispState = DisplayState { display = disp } + (res, _) <-runStateT (runStateT (runDisplayM f) initialState) dispState + wlDisplayDestroy disp + return res bindSocket :: DisplayM s String -bindSocket = undefined +bindSocket = do + disp <- DisplayM $ lift $ gets display + name <- liftIO $ wlDisplayAddSocketAuto disp + liftIO $ peekCString name processRequests :: (Request -> DisplayM s ()) -> DisplayM s () -processRequests _ = undefined +processRequests _ = do + disp <- DisplayM $ lift $ gets display + liftIO $ wlDisplayRun disp -sendEvent :: Resource r => r -> ResourceEvent r -> DisplayM s () +sendEvent :: ResourceClass r => r -> ResourceEvent r -> DisplayM s () sendEvent _ _ = undefined flushEvents :: DisplayM s () flushEvents = undefined -destroyResource :: Resource r => r -> DisplayM s () +destroyResource :: ResourceClass r => r -> DisplayM s () destroyResource _ = undefined -registerGlobal :: Resource r => Typeable req => (r -> req) -> DisplayM s Global -registerGlobal _ = undefined +registerGlobal :: ResourceClass r => Typeable req => (r -> req) -> DisplayM s Global +registerGlobal _ = pure Global unregisterGlobal :: Global -> DisplayM s () -unregisterGlobal _ = undefined +unregisterGlobal _ = pure () diff --git a/wayland/Wayland/Server/System.hsc b/wayland/Wayland/Server/System.hsc new file mode 100644 index 0000000..d86f59a --- /dev/null +++ b/wayland/Wayland/Server/System.hsc @@ -0,0 +1,92 @@ +{-# LANGUAGE ForeignFunctionInterface #-} + +module Wayland.Server.System + ( WLMessage(..) + , WLInterface(..) + , WLDisplay(WLDisplay) + , wlDisplayCreate + , wlDisplayDestroy + , wlDisplayAddSocketAuto + , wlDisplayRun + , wlDisplayTerminate + ) where + +#include <wayland-server.h> + +import Foreign (Ptr, Storable(..)) +import Foreign.C (CString, CInt) + +data WLMessage + = WLMessage { msgName :: CString + , msgSignature :: CString + , msgTypes :: Ptr (Ptr WLInterface) + } + +data WLInterface + = WLInterface { ifName :: CString + , ifVersion :: CInt + , ifMethodCount :: CInt + , ifMethods :: Ptr WLMessage + , ifEventCount :: CInt + , ifEvents :: Ptr WLMessage + } + +newtype WLDisplay = WLDisplay (Ptr WLDisplay) + +foreign import ccall "wl_display_create" + wlDisplayCreate :: IO WLDisplay + +foreign import ccall "wl_display_destroy" + wlDisplayDestroy :: 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 () + +instance Storable WLMessage where + sizeOf _ = #{size struct wl_message} + alignment _ = #{alignment struct wl_message} + peek p = do + name <- #{peek struct wl_message, name} p + signature <- #{peek struct wl_message, signature} p + types <- #{peek struct wl_message, types} p + return $ WLMessage { msgName = name + , msgSignature = signature + , msgTypes = types + } + poke p m = do + #{poke struct wl_message, name} p $ msgName m + #{poke struct wl_message, signature} p $ msgSignature m + #{poke struct wl_message, types} p $ msgTypes m + return () + +instance Storable WLInterface where + sizeOf _ = #{size struct wl_interface} + alignment _ = #{alignment struct wl_interface} + peek p = do + name <- #{peek struct wl_interface, name} p + version <- #{peek struct wl_interface, version} p + methodCount <- #{peek struct wl_interface, method_count} p + methods <- #{peek struct wl_interface, methods} p + eventCount <- #{peek struct wl_interface, event_count} p + events <- #{peek struct wl_interface, events} p + return $ WLInterface { ifName = name + , ifVersion = version + , ifMethodCount = methodCount + , ifMethods = methods + , ifEventCount = eventCount + , ifEvents = events + } + poke p m = do + #{poke struct wl_interface, name} p $ ifName m + #{poke struct wl_interface, version} p $ ifVersion m + #{poke struct wl_interface, method_count} p $ ifMethodCount m + #{poke struct wl_interface, methods} p $ ifMethods m + #{poke struct wl_interface, event_count} p $ ifEventCount m + #{poke struct wl_interface, events} p $ ifEvents m + return () |