diff options
Diffstat (limited to 'wayland/Wayland')
| -rw-r--r-- | wayland/Wayland/Server.hs | 41 | ||||
| -rw-r--r-- | wayland/Wayland/Server/System.hsc | 14 |
2 files changed, 44 insertions, 11 deletions
diff --git a/wayland/Wayland/Server.hs b/wayland/Wayland/Server.hs index b0c5b89..7d60512 100644 --- a/wayland/Wayland/Server.hs +++ b/wayland/Wayland/Server.hs @@ -5,6 +5,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ScopedTypeVariables #-} module Wayland.Server ( Request(..) @@ -30,7 +31,7 @@ module Wayland.Server , requestTermination ) where -import Data.Typeable (Typeable, Proxy, cast, TypeRep, typeRep) +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) @@ -49,10 +50,11 @@ import Control.Monad (when) import Data.Maybe (isJust) import qualified Data.Map as M import Foreign.Marshal (newArray) +import Data.Word (Word32) data Global = Global -newtype ObjectID = ObjectID String +data ObjectID = ObjectID deriving (Show, Eq, Ord) data Nullability @@ -113,14 +115,13 @@ makeLenses ''DisplayState class Typeable r => ResourceClass r where type ResourceRequest r :: Type type ResourceEvent r :: Type - objectID :: r -> ObjectID - interface :: Proxy r -> InterfaceDesc - + objectID :: r -> ObjectID + fromID :: ObjectID -> r + interface :: Proxy r -> InterfaceDesc instance Show Request where show (Request r) = show r - type instance Zoomed (DisplayM s) = Zoomed (StateT s (StateT DisplayState (ReaderT Display IO))) instance Zoom (DisplayM s) (DisplayM t) s t where @@ -173,16 +174,33 @@ processRequests h = do liftDisplayState $ put displayStateAfter sendEvent :: ResourceClass r => r -> ResourceEvent r -> DisplayM s () -sendEvent _ _ = undefined +sendEvent _ _ = pure () -- TODO flushEvents :: DisplayM s () -flushEvents = undefined +flushEvents = pure () -- TODO destroyResource :: ResourceClass r => r -> DisplayM s () -destroyResource _ = undefined +destroyResource _ = pure () -- TODO -registerGlobal :: ResourceClass r => RequestClass req => (r -> req) -> DisplayM s Global -registerGlobal _ = pure Global +registerGlobal :: forall r req s. ResourceClass r => RequestClass req => (r -> req) -> Int -> DisplayM s Global +registerGlobal mkReq version = do + disp <- getDisplay + iface <- getInterface (Proxy :: Proxy r) + let createObject :: Sys.WLClient -> Ptr () -> Word32 -> Word32 -> IO () + createObject client _ ver objID = do + _ <- Sys.wlResourceCreate client iface (fromIntegral ver) objID + -- TODO: Bind functions + -- TODO: Wrap resource into ObjectID + let req = mkReq (fromID ObjectID) + runRequest disp (Request req) + pure () + liftIO $ do + func <- Sys.wrapWLGlobalBindFunc createObject + _ <- Sys.wlGlobalCreate (display disp) iface (fromIntegral version) nullPtr func + -- TODO: Free func + -- TODO: Return proper Global + pure () + pure Global unregisterGlobal :: Global -> DisplayM s () unregisterGlobal _ = pure () @@ -202,6 +220,7 @@ registerSignalEvent r sig = do func <- Sys.wrapWLEventLoopSignalFunc $ \_ _ -> runRequest disp (Request r) $> 0 _ <- Sys.wlEventLoopAddSignal loop sig func nullPtr -- TODO: Free func + -- TODO: Return event source handle pure () requestTermination :: DisplayM s () diff --git a/wayland/Wayland/Server/System.hsc b/wayland/Wayland/Server/System.hsc index f758a65..6fcd52c 100644 --- a/wayland/Wayland/Server/System.hsc +++ b/wayland/Wayland/Server/System.hsc @@ -6,6 +6,7 @@ module Wayland.Server.System where import Foreign (FunPtr, Ptr, Storable(..)) import Foreign.C (CString, CInt(..)) +import Data.Word (Word32) data WLMessage = WLMessage { msgName :: CString @@ -27,12 +28,19 @@ data WLInterface newtype WLDisplay = WLDisplay (Ptr WLDisplay) newtype WLEventLoop = WLEventLoop (Ptr WLEventLoop) newtype WLEventSource = WLEventSource (Ptr WLEventSource) +newtype WLGlobal = WLGlobal (Ptr WLGlobal) +newtype WLClient = WLClient (Ptr WLClient) +newtype WLResource = WLResource (Ptr WLResource) type WLEventLoopSignalFunc = CInt -> Ptr () -> IO CInt +type WLGlobalBindFunc = WLClient -> Ptr () -> Word32 -> Word32 -> IO () foreign import ccall "wrapper" wrapWLEventLoopSignalFunc :: WLEventLoopSignalFunc -> IO (FunPtr WLEventLoopSignalFunc) +foreign import ccall "wrapper" + wrapWLGlobalBindFunc :: WLGlobalBindFunc -> IO (FunPtr WLGlobalBindFunc) + foreign import ccall "wl_display_create" wlDisplayCreate :: IO WLDisplay @@ -54,6 +62,12 @@ foreign import ccall "wl_display_get_event_loop" 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 + instance Storable WLMessage where sizeOf _ = #{size struct wl_message} alignment _ = #{alignment struct wl_message} |