├── .gitignore ├── Graphics ├── Wayland.hs └── Wayland │ ├── Client.hs │ ├── Internal.hs │ ├── Internal │ ├── Client.chs │ ├── Cursor.chs │ ├── EGL.chs │ ├── Server.chs │ ├── ServerClientState.chs │ ├── SpliceClient.hs │ ├── SpliceClientInternal.hs │ ├── SpliceClientTypes.hs │ ├── SpliceServer.hs │ ├── SpliceServerInternal.hs │ ├── SpliceServerTypes.hs │ ├── Util.chs │ └── Version.chs │ ├── Scanner.chs │ ├── Scanner │ ├── Marshaller.chs │ ├── Names.hs │ ├── Protocol.hs │ └── Types.chs │ └── Server.hs ├── LICENSE ├── NOTES.md ├── README.md ├── Setup.hs ├── hayland.cabal └── tests ├── enums.hs ├── listglobals.hs └── test.hs /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | cabal-dev 3 | *.o 4 | *.hi 5 | *.chi 6 | *.chs.h 7 | .cabal-sandbox 8 | cabal.sandbox.config 9 | TAGS 10 | tags 11 | -------------------------------------------------------------------------------- /Graphics/Wayland.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | 3 | module Graphics.Wayland ( 4 | version, Fixed256, Precision256, Time, Result(..), errToResult, 5 | diffTimeToTime, timeToDiffTime, ProtocolVersion(..), scannedVersionOf 6 | ) where 7 | 8 | import Foreign.C.Types 9 | import Data.Proxy 10 | 11 | import Graphics.Wayland.Internal.Util 12 | import Graphics.Wayland.Internal.Version 13 | 14 | 15 | data Result = Success | Failure deriving (Eq, Show) 16 | errToResult :: CInt -> Result 17 | errToResult 0 = Success 18 | errToResult (-1) = Failure 19 | 20 | class ProtocolVersion a where 21 | protocolVersion :: Proxy a -> Int 22 | 23 | scannedVersionOf :: forall a. (ProtocolVersion a) => a -> Int 24 | scannedVersionOf x = protocolVersion (Proxy :: Proxy a) 25 | -------------------------------------------------------------------------------- /Graphics/Wayland/Client.hs: -------------------------------------------------------------------------------- 1 | module Graphics.Wayland.Client ( 2 | -- Expose built-in wayland functions 3 | module Graphics.Wayland.Internal.Client, 4 | module Graphics.Wayland.Internal.Cursor, 5 | module Graphics.Wayland.Internal.EGL, 6 | -- Expose scanned protocol 7 | module Graphics.Wayland.Internal.SpliceClient, 8 | module Graphics.Wayland.Internal.SpliceClientTypes, 9 | ) where 10 | 11 | import Graphics.Wayland.Internal.Client 12 | import Graphics.Wayland.Internal.SpliceClient 13 | import Graphics.Wayland.Internal.SpliceClientTypes 14 | import Graphics.Wayland.Internal.Cursor 15 | import Graphics.Wayland.Internal.EGL 16 | -------------------------------------------------------------------------------- /Graphics/Wayland/Internal.hs: -------------------------------------------------------------------------------- 1 | module Graphics.Wayland.Internal where 2 | -------------------------------------------------------------------------------- /Graphics/Wayland/Internal/Client.chs: -------------------------------------------------------------------------------- 1 | module Graphics.Wayland.Internal.Client ( 2 | Result(..), 3 | 4 | displayConnect, displayConnectName, displayConnectFd, displayDisconnect, displayGetFd, 5 | displayDispatch, displayDispatchPending, 6 | 7 | displayGetError, displayFlush, displayRoundtrip, 8 | 9 | displayPrepareRead, displayCancelRead, displayReadEvents 10 | ) where 11 | 12 | import Foreign 13 | import Foreign.C.Types 14 | import Foreign.C.String 15 | import System.Posix.Types 16 | 17 | import Graphics.Wayland.Internal.SpliceClientTypes (Display(..)) 18 | import Graphics.Wayland.Internal.SpliceClientInternal 19 | import Graphics.Wayland.Internal.SpliceClient 20 | import Graphics.Wayland 21 | 22 | 23 | #include 24 | 25 | {#context prefix="wl"#} 26 | 27 | unFd :: Fd -> CInt 28 | unFd (Fd k) = k 29 | 30 | makeWith' :: b -> (b -> IO c) -> IO c 31 | makeWith' b f = f b 32 | 33 | withNullPtr = makeWith' nullPtr 34 | 35 | codeToNothing :: Int -> Int -> Maybe Int 36 | codeToNothing j k 37 | | j == k = Nothing 38 | | otherwise = Just k 39 | 40 | codeNeg1ToNothing :: CInt -> Maybe Int 41 | codeNeg1ToNothing = codeToNothing (-1) . fromIntegral 42 | 43 | code0ToNothing :: CInt -> Maybe Int 44 | code0ToNothing = codeToNothing 0 . fromIntegral 45 | 46 | -- Data types 47 | 48 | -- In the case of the Client side, these are all just abstract pointer objects. 49 | 50 | -- struct wl_display pointer (nocode since its interface is generated in SpliceProtocol) 51 | {#pointer * display as Display nocode#} 52 | 53 | -- -- | struct wl_event_queue pointer (generate type since this is not an interface) 54 | -- {#pointer * event_queue as EventQueue newtype#} 55 | 56 | -- -- | struct wl_interface pointer. for internal use only. (proxy typing) 57 | -- {#pointer * interface as Interface newtype#} 58 | 59 | 60 | 61 | -- Functions/methods 62 | 63 | 64 | -- -- void wl_event_queue_destroy(struct wl_event_queue *queue); 65 | -- {#fun unsafe event_queue_destroy as ^ {`EventQueue'} -> `()'#} 66 | 67 | -- void wl_proxy_marshal(struct wl_proxy *p, uint32_t opcode, ...); 68 | 69 | -- void wl_proxy_marshal_array(struct wl_proxy *p, uint32_t opcode, 70 | -- union wl_argument *args); 71 | 72 | -- struct wl_proxy *wl_proxy_create(struct wl_proxy *factory, 73 | -- const struct wl_interface *interface); 74 | 75 | -- struct wl_proxy *wl_proxy_marshal_constructor(struct wl_proxy *proxy, 76 | -- uint32_t opcode, 77 | -- const struct wl_interface *interface, 78 | -- ...); 79 | -- struct wl_proxy * 80 | -- wl_proxy_marshal_array_constructor(struct wl_proxy *proxy, 81 | -- uint32_t opcode, union wl_argument *args, 82 | -- const struct wl_interface *interface); 83 | 84 | -- void wl_proxy_destroy(struct wl_proxy *proxy); 85 | -- int wl_proxy_add_listener(struct wl_proxy *proxy, 86 | -- void (**implementation)(void), void *data); 87 | -- const void *wl_proxy_get_listener(struct wl_proxy *proxy); 88 | -- int wl_proxy_add_dispatcher(struct wl_proxy *proxy, 89 | -- wl_dispatcher_func_t dispatcher_func, 90 | -- const void * dispatcher_data, void *data); 91 | -- void wl_proxy_set_user_data(struct wl_proxy *proxy, void *user_data); 92 | -- void *wl_proxy_get_user_data(struct wl_proxy *proxy); 93 | -- uint32_t wl_proxy_get_id(struct wl_proxy *proxy); 94 | -- const char *wl_proxy_get_class(struct wl_proxy *proxy); 95 | -- void wl_proxy_set_queue(struct wl_proxy *proxy, struct wl_event_queue *queue); 96 | 97 | 98 | receiveMaybeDisplay :: Display -> Maybe Display 99 | receiveMaybeDisplay (Display x) 100 | | x == nullPtr = Nothing 101 | | otherwise = Just (Display x) 102 | 103 | -- struct wl_display *wl_display_connect(const char *name); 104 | -- | Connect to a display with a specified name 105 | {#fun unsafe display_connect as displayConnectName {`String'} -> `Maybe Display' receiveMaybeDisplay #} 106 | 107 | -- | Connect to the default display by passing a null pointer 108 | {#fun unsafe display_connect as displayConnect {withNullPtr- `Ptr CChar'} -> `Maybe Display' receiveMaybeDisplay #} 109 | 110 | -- struct wl_display *wl_display_connect_to_fd(int fd); 111 | -- | Connect to a display by file descriptor 112 | {#fun unsafe display_connect_to_fd as displayConnectFd {unFd `Fd'} -> `Maybe Display' receiveMaybeDisplay #} 113 | 114 | -- void wl_display_disconnect(struct wl_display *display); 115 | {#fun unsafe display_disconnect as displayDisconnect {`Display'} -> `()' #} 116 | 117 | -- int wl_display_get_fd(struct wl_display *display); 118 | {#fun unsafe display_get_fd as displayGetFd {`Display'} -> `Fd' Fd #} 119 | 120 | -- int wl_display_dispatch(struct wl_display *display); 121 | -- | wl_display_dispatch. Returns @Nothing@ on failure or @Just k@ if k events were processed. 122 | -- 123 | -- Strictly safe!!! This *will* call back into Haskell code! 124 | {#fun display_dispatch as displayDispatch {`Display'} -> `Maybe Int' codeNeg1ToNothing #} 125 | 126 | -- -- int wl_display_dispatch_queue(struct wl_display *display, 127 | -- -- struct wl_event_queue *queue); 128 | -- -- | wl_display_dispatch_queue. Returns @Nothing@ on failure or @Just k@ if k events were processed. 129 | -- -- 130 | -- -- Strictly safe!!! This *will* call back into Haskell code! 131 | -- {#fun display_dispatch_queue as displayDispatchQueue {`Display', `EventQueue'} -> `Maybe Int' codeNeg1ToNothing #} 132 | 133 | -- -- int wl_display_dispatch_queue_pending(struct wl_display *display, 134 | -- -- struct wl_event_queue *queue); 135 | -- -- | wl_display_dispatch_queue_pending. Returns @Nothing@ on failure or @Just k@ if k events were processed. 136 | -- -- 137 | -- -- Strictly safe!!! This *will* call back into Haskell code! 138 | -- {#fun display_dispatch_queue_pending as displayDispatchQueuePending {`Display', `EventQueue'} -> `Maybe Int' codeNeg1ToNothing #} 139 | 140 | -- int wl_display_dispatch_pending(struct wl_display *display); 141 | -- | wl_display_dispatch_pending. Returns @Nothing@ on failure or @Just k@ if k events were processed. 142 | -- 143 | -- Strictly safe!!! This *will* call back into Haskell code! 144 | {#fun display_dispatch_pending as displayDispatchPending {`Display'} -> `Maybe Int' codeNeg1ToNothing #} 145 | 146 | -- int wl_display_get_error(struct wl_display *display); 147 | -- | @Nothing@ if no error occurred or @Just k@ if the latest error had code k 148 | -- 149 | -- Note (from the wayland documentation): errors are fatal. If this function returns a @Just@ value, the display can no longer be used. 150 | {#fun unsafe display_get_error as displayGetError {`Display'} -> `Maybe Int' code0ToNothing #} 151 | 152 | -- int wl_display_flush(struct wl_display *display); 153 | -- | @Nothing@ on failure or @Just k@ if k bytes were sent 154 | -- 155 | -- __It is not clear to me if this is can be unsafe (ie. can this call back into haskell code?).__ 156 | {#fun display_flush as displayFlush {`Display'} -> `Maybe Int' codeNeg1ToNothing #} 157 | 158 | -- int wl_display_roundtrip(struct wl_display *display); 159 | -- | @Nothing@ on failure or @Just k@ if k events were dispatched. 160 | -- 161 | -- __It is not clear to me if this is can be unsafe (ie. can this call back into haskell code?).__ 162 | {#fun display_roundtrip as displayRoundtrip {`Display'} -> `Maybe Int' codeNeg1ToNothing #} 163 | 164 | -- -- struct wl_event_queue *wl_display_create_queue(struct wl_display *display); 165 | -- -- | Docs say that wl_display_create_queue may return NULL on failure, but that only happens when it's out of memory 166 | -- {#fun unsafe display_create_queue as displayCreateQueue {`Display'} -> `EventQueue' #} 167 | 168 | -- -- int wl_display_prepare_read_queue(struct wl_display *display, 169 | -- -- struct wl_event_queue *queue); 170 | -- {#fun unsafe display_prepare_read_queue as displayPrepareReadQueue {`Display', `EventQueue'} -> `Result' errToResult #} 171 | 172 | -- int wl_display_prepare_read(struct wl_display *display); 173 | {#fun unsafe display_prepare_read as displayPrepareRead {`Display'} -> `Result' errToResult #} 174 | 175 | -- void wl_display_cancel_read(struct wl_display *display); 176 | {#fun unsafe display_cancel_read as displayCancelRead {`Display'} -> `()' #} 177 | 178 | -- int wl_display_read_events(struct wl_display *display); 179 | -- | This will read events from the file descriptor for the display. 180 | -- This function does not dispatch events, it only reads and queues events into their corresponding event queues. 181 | -- 182 | -- Before calling this function, wl_display_prepare_read() must be called first. 183 | {#fun unsafe display_read_events as displayReadEvents {`Display'} -> `Result' errToResult #} 184 | 185 | -- void wl_log_set_handler_client(wl_log_func_t handler); 186 | -------------------------------------------------------------------------------- /Graphics/Wayland/Internal/Cursor.chs: -------------------------------------------------------------------------------- 1 | -- | This is client-side code for loading cursor themes. Provided for convenience only. 2 | module Graphics.Wayland.Internal.Cursor ( 3 | CursorTheme, CursorImage, Cursor, 4 | cursorImageSize, cursorImageHotspot, cursorImageDelay, 5 | cursorName, cursorImages, 6 | 7 | cursorThemeLoad, cursorThemeDestroy, cursorThemeGetCursor, cursorImageGetBuffer, cursorFrame 8 | ) where 9 | 10 | import Control.Monad (liftM) 11 | import Foreign 12 | import Foreign.C.Types 13 | import Foreign.C.String 14 | import System.IO.Unsafe (unsafePerformIO) 15 | 16 | import Graphics.Wayland.Internal.SpliceClientTypes (Shm(..), Buffer(..)) 17 | 18 | #include 19 | 20 | {#context prefix="wl"#} 21 | 22 | 23 | -- | struct wl_cursor_theme; 24 | {#pointer * cursor_theme as CursorTheme newtype#} 25 | 26 | 27 | -- | struct wl_cursor_image { 28 | -- uint32_t width; /* actual width */ 29 | -- uint32_t height; /* actual height */ 30 | -- uint32_t hotspot_x; /* hot spot x (must be inside image) */ 31 | -- uint32_t hotspot_y; /* hot spot y (must be inside image) */ 32 | -- uint32_t delay; /* animation delay to next frame (ms) */ 33 | -- }; 34 | {#pointer * cursor_image as CursorImage newtype#} 35 | 36 | cursorImageSize :: CursorImage -> (Word, Word) 37 | cursorImageSize (CursorImage ci) = unsafePerformIO $ do -- CursorImages are immutable 38 | width <- {#get cursor_image->width#} ci 39 | height <- {#get cursor_image->height#} ci 40 | return (fromIntegral width, fromIntegral height) 41 | 42 | cursorImageHotspot :: CursorImage -> (Word, Word) 43 | cursorImageHotspot (CursorImage ci) = unsafePerformIO $ do -- CursorImages are immutable 44 | x <- {#get cursor_image->hotspot_x#} ci 45 | y <- {#get cursor_image->hotspot_y#} ci 46 | return (fromIntegral x, fromIntegral y) 47 | 48 | cursorImageDelay :: CursorImage -> Word 49 | cursorImageDelay (CursorImage ci) = unsafePerformIO $ liftM fromIntegral $ {#get cursor_image->delay#} ci -- CursorImages are immutable 50 | 51 | -- | struct wl_cursor { 52 | -- unsigned int image_count; 53 | -- struct wl_cursor_image **images; 54 | -- char *name; 55 | -- }; 56 | {#pointer * cursor as Cursor newtype#} 57 | cursorName :: Cursor -> String 58 | cursorName (Cursor c) = unsafePerformIO $ do 59 | cstr <- {#get cursor->name#} c 60 | peekCString cstr 61 | 62 | cursorImages :: Cursor -> [CursorImage] 63 | cursorImages (Cursor c) = unsafePerformIO $ do 64 | imagesPtr <- (\ ptr -> (peekByteOff ptr {#offsetof cursor->images#} :: IO (Ptr (Ptr CursorImage)))) c 65 | count <- {#get cursor->image_count#} c 66 | return imagesPtr 67 | ptrs <- peekArray (fromIntegral count) imagesPtr 68 | return $ map CursorImage ptrs 69 | 70 | -- struct wl_shm; 71 | {#pointer * shm as Shm nocode#} 72 | 73 | -- | struct wl_cursor_theme * 74 | -- wl_cursor_theme_load(const char *name, int size, struct wl_shm *shm); 75 | {#fun unsafe cursor_theme_load as cursorThemeLoad {`String', `Int', `Shm'} -> `CursorTheme'#} 76 | 77 | -- | void 78 | -- wl_cursor_theme_destroy(struct wl_cursor_theme *theme); 79 | {#fun unsafe cursor_theme_destroy as cursorThemeDestroy {`CursorTheme'} -> `()' #} 80 | 81 | -- | struct wl_cursor * 82 | -- wl_cursor_theme_get_cursor(struct wl_cursor_theme *theme, 83 | -- const char *name); 84 | {#fun unsafe cursor_theme_get_cursor as cursorThemeGetCursor {`CursorTheme', `String'} -> `Cursor' #} 85 | 86 | {#pointer * buffer as Buffer nocode#} 87 | -- | struct wl_buffer * 88 | -- wl_cursor_image_get_buffer(struct wl_cursor_image *image); 89 | -- 90 | -- From the wayland docs: do not destroy the returned buffer. 91 | {#fun unsafe cursor_image_get_buffer as cursorImageGetBuffer {`CursorImage'} -> `Buffer' #} 92 | 93 | -- | int 94 | -- wl_cursor_frame(struct wl_cursor *cursor, uint32_t time); 95 | {#fun unsafe cursor_frame as cursorFrame {`Cursor', `Int'} -> `Int' #} 96 | -------------------------------------------------------------------------------- /Graphics/Wayland/Internal/EGL.chs: -------------------------------------------------------------------------------- 1 | -- | Client-side 2 | module Graphics.Wayland.Internal.EGL ( 3 | EGLWindow, eglWindowCreate, eglWindowDestroy, eglWindowResize, eglWindowGetAttachedSize 4 | ) where 5 | 6 | 7 | import Control.Monad 8 | import Foreign 9 | import Foreign.C.Types 10 | import Foreign.C.String 11 | 12 | import Graphics.Wayland.Internal.SpliceClientTypes (Surface(..)) 13 | 14 | #include 15 | 16 | {#context prefix="wl"#} 17 | 18 | 19 | -- lol this is 100% unused. 20 | -- #define WL_EGL_PLATFORM 1 21 | 22 | {#pointer * surface as Surface nocode#} 23 | 24 | -- struct wl_egl_window; 25 | {#pointer * egl_window as EGLWindow newtype#} 26 | 27 | -- struct wl_egl_window * 28 | -- wl_egl_window_create(struct wl_surface *surface, 29 | -- int width, int height); 30 | {#fun unsafe egl_window_create as eglWindowCreate {`Surface', `Int', `Int'} -> `EGLWindow' #} 31 | 32 | -- void 33 | -- wl_egl_window_destroy(struct wl_egl_window *egl_window); 34 | {#fun unsafe egl_window_destroy as eglWindowDestroy {`EGLWindow'} -> `()' #} 35 | 36 | -- void 37 | -- wl_egl_window_resize(struct wl_egl_window *egl_window, 38 | -- int width, int height, 39 | -- int dx, int dy); 40 | {#fun unsafe egl_window_resize as eglWindowResize {`EGLWindow', `Int', `Int', `Int', `Int'} -> `()' #} 41 | 42 | 43 | -- void 44 | -- wl_egl_window_get_attached_size(struct wl_egl_window *egl_window, 45 | -- int *width, int *height); 46 | -- withInt = with.fromIntegral 0 47 | peekInt = liftM fromIntegral . peek 48 | {#fun unsafe egl_window_get_attached_size as eglWindowGetAttachedSize {`EGLWindow', alloca- `Int' peekInt*, alloca- `Int' peekInt*} -> `()' #} 49 | -------------------------------------------------------------------------------- /Graphics/Wayland/Internal/Server.chs: -------------------------------------------------------------------------------- 1 | -- Trying my best to piss off the Safe Haskell guys 2 | {-# LANGUAGE TemplateHaskell, GeneralizedNewtypeDeriving #-} 3 | module Graphics.Wayland.Internal.Server ( 4 | ClientState(..), clientStateReadable, clientStateWritable, clientStateHangup, 5 | clientStateError, 6 | 7 | EventLoop, EventSource, 8 | 9 | EventLoopFdFunc, EventLoopTimerFunc, EventLoopSignalFunc, EventLoopIdleFunc, 10 | 11 | eventLoopCreate, eventLoopDestroy, eventLoopAddFd, eventSourceFdUpdate, 12 | eventLoopAddTimer, eventLoopAddSignal, eventSourceTimerUpdate, eventSourceRemove, 13 | eventSourceCheck, eventLoopDispatch, eventLoopDispatchIdle, eventLoopAddIdle, eventLoopGetFd, 14 | 15 | DisplayServer, displayCreate, displayDestroy, displayGetEventLoop, displayAddSocket, 16 | displayTerminate, displayRun, displayFlushClients, displayGetSerial, displayNextSerial, 17 | 18 | clientCreate, clientDestroy, clientFlush, clientGetCredentials, clientPostNoMemory, 19 | 20 | ShmBuffer, shmBufferBeginAccess, shmBufferEndAccess, shmBufferGet, shmBufferGetData, 21 | shmBufferGetStride, shmBufferGetFormat, shmBufferGetWidth, shmBufferGetHeight, 22 | displayInitShm, displayAddShmFormat, shmBufferCreate 23 | ) where 24 | 25 | import Control.Monad (liftM) 26 | import Data.Functor ((<$>)) 27 | import Data.Flags 28 | import Data.Flags.TH 29 | import Foreign 30 | import Foreign.C.Types 31 | import Foreign.C.String 32 | import System.Posix.Types 33 | 34 | import Graphics.Wayland.Internal.ServerClientState -- for the WL_EVENT_* constants 35 | import Graphics.Wayland.Internal.SpliceServerTypes (Buffer(..)) 36 | import Graphics.Wayland.Internal.SpliceServerInternal 37 | import Graphics.Wayland.Internal.SpliceServer 38 | import Graphics.Wayland.Internal.Util (Client(..)) 39 | import Graphics.Wayland 40 | 41 | 42 | #include 43 | 44 | {#context prefix="wl"#} 45 | 46 | 47 | 48 | 49 | 50 | boolToCInt :: Bool -> CInt 51 | boolToCInt True = 1 52 | boolToCInt False = 0 53 | 54 | 55 | 56 | unFd :: Fd -> CInt 57 | unFd (Fd n) = n 58 | 59 | makeWith :: (a -> IO b) -> (a -> (b -> IO c) -> IO c) 60 | makeWith func = \ a f -> do 61 | b <- func a 62 | f b 63 | 64 | makeWith' :: b -> (b -> IO c) -> IO c 65 | makeWith' b f = f b 66 | 67 | withNullPtr = makeWith' nullPtr 68 | 69 | -- | enum { 70 | -- WL_EVENT_READABLE = 0x01, 71 | -- WL_EVENT_WRITABLE = 0x02, 72 | -- WL_EVENT_HANGUP = 0x04, 73 | -- WL_EVENT_ERROR = 0x08 74 | -- }; 75 | -- 76 | -- The "uint32_t mask" argument passed to a variety of functions in this file is a bitmask 77 | -- detailing the state of the client. 78 | $(bitmaskWrapper "ClientState" ''CUInt [''Num, ''Integral, ''Real, ''Enum, ''Ord] [ 79 | ("clientStateReadable", fromIntegral $ fromEnum ClientReadable), 80 | ("clientStateWritable", fromIntegral $ fromEnum ClientWritable), 81 | ("clientStateHangup", fromIntegral $ fromEnum ClientHangup), 82 | ("clientStateError", fromIntegral $ fromEnum ClientError) 83 | ]) 84 | 85 | -- | struct wl_event_loop; 86 | {#pointer * event_loop as EventLoop newtype#} 87 | 88 | -- | struct wl_event_source; 89 | {#pointer * event_source as EventSource newtype#} 90 | 91 | type CEventLoopFdFunc = CInt -> {#type uint32_t#} -> Ptr () -> IO CInt 92 | -- | typedef int (*wl_event_loop_fd_func_t)(int fd, uint32_t mask, void *data); 93 | type EventLoopFdFunc = Int -> ClientState -> IO Bool 94 | foreign import ccall unsafe "wrapper" makeFdFunPtr :: CEventLoopFdFunc -> IO (FunPtr CEventLoopFdFunc) 95 | marshallEventLoopFdFunc :: EventLoopFdFunc -> IO (FunPtr CEventLoopFdFunc) 96 | marshallEventLoopFdFunc func = makeFdFunPtr $ \ fd mask _ -> boolToCInt <$> func (fromIntegral fd) (fromIntegral mask) 97 | melff = makeWith marshallEventLoopFdFunc 98 | 99 | type CEventLoopTimerFunc = Ptr () -> IO CInt 100 | -- | typedef int (*wl_event_loop_timer_func_t)(void *data); 101 | type EventLoopTimerFunc = IO Bool 102 | foreign import ccall unsafe "wrapper" makeTimerFunPtr :: CEventLoopTimerFunc -> IO (FunPtr CEventLoopTimerFunc) 103 | marshallEventLoopTimerFunc :: EventLoopTimerFunc -> IO (FunPtr CEventLoopTimerFunc) 104 | marshallEventLoopTimerFunc func = makeTimerFunPtr $ \ _ -> boolToCInt <$> func 105 | meltf = makeWith marshallEventLoopTimerFunc 106 | 107 | type CEventLoopSignalFunc = CInt -> Ptr () -> IO CInt 108 | -- | typedef int (*wl_event_loop_signal_func_t)(int signal_number, void *data); 109 | type EventLoopSignalFunc = Int -> IO Bool 110 | foreign import ccall unsafe "wrapper" makeSignalFunPtr :: CEventLoopSignalFunc -> IO (FunPtr CEventLoopSignalFunc) 111 | marshallEventLoopSignalFunc :: EventLoopSignalFunc -> IO (FunPtr CEventLoopSignalFunc) 112 | marshallEventLoopSignalFunc func = makeSignalFunPtr $ \ x _ -> boolToCInt <$> func (fromIntegral x) 113 | melsf = makeWith marshallEventLoopSignalFunc 114 | 115 | -- typedef void (*wl_event_loop_idle_func_t)(void *data); 116 | type CEventLoopIdleFunc = Ptr () -> IO () 117 | type EventLoopIdleFunc = IO () 118 | foreign import ccall unsafe "wrapper" makeIdleFunPtr :: CEventLoopIdleFunc -> IO (FunPtr CEventLoopIdleFunc) 119 | marshallEventLoopIdleFunc :: EventLoopIdleFunc -> IO (FunPtr CEventLoopIdleFunc) 120 | marshallEventLoopIdleFunc func = makeIdleFunPtr $ \ _ -> func 121 | melif = makeWith marshallEventLoopIdleFunc 122 | 123 | -- |struct wl_event_loop *wl_event_loop_create(void); 124 | {#fun unsafe event_loop_create as eventLoopCreate {} -> `EventLoop' #} 125 | 126 | -- |void wl_event_loop_destroy(struct wl_event_loop *loop); 127 | {#fun unsafe event_loop_destroy as eventLoopDestroy {`EventLoop'} -> `()' #} 128 | 129 | -- | struct wl_event_source *wl_event_loop_add_fd(struct wl_event_loop *loop, 130 | -- int fd, uint32_t mask, 131 | -- wl_event_loop_fd_func_t func, 132 | -- void *data); 133 | {#fun unsafe event_loop_add_fd as eventLoopAddFd {`EventLoop', unFd `Fd', fromIntegral `ClientState', melff* `EventLoopFdFunc', withNullPtr- `Ptr ()'} -> `EventSource' #} 134 | 135 | -- | int wl_event_source_fd_update(struct wl_event_source *source, uint32_t mask); 136 | {#fun unsafe event_source_fd_update as eventSourceFdUpdate {`EventSource', fromIntegral `ClientState'} -> `Result' errToResult #} 137 | 138 | -- | struct wl_event_source *wl_event_loop_add_timer(struct wl_event_loop *loop, 139 | -- wl_event_loop_timer_func_t func, 140 | -- void *data); 141 | {#fun unsafe event_loop_add_timer as eventLoopAddTimer {`EventLoop', meltf* `EventLoopTimerFunc', withNullPtr- `Ptr ()'} -> `EventSource'#} 142 | 143 | -- | struct wl_event_source * 144 | -- wl_event_loop_add_signal(struct wl_event_loop *loop, 145 | -- int signal_number, 146 | -- wl_event_loop_signal_func_t func, 147 | -- void *data); 148 | {#fun unsafe event_loop_add_signal as eventLoopAddSignal {`EventLoop', `Int', melsf* `EventLoopSignalFunc', withNullPtr- `Ptr ()'} -> `EventSource' #} 149 | 150 | -- | int wl_event_source_timer_update(struct wl_event_source *source, 151 | -- int ms_delay); 152 | {#fun unsafe event_source_timer_update as eventSourceTimerUpdate {`EventSource', `Int'} -> `Result' errToResult #} 153 | 154 | -- | int wl_event_source_remove(struct wl_event_source *source); 155 | {#fun unsafe event_source_remove as eventSourceRemove {`EventSource'} -> `()' #} 156 | 157 | -- | void wl_event_source_check(struct wl_event_source *source); 158 | {#fun unsafe event_source_check as eventSourceCheck {`EventSource'} -> `()' #} 159 | 160 | -- | int wl_event_loop_dispatch(struct wl_event_loop *loop, int timeout); 161 | -- 162 | -- SAFE!! 163 | {#fun event_loop_dispatch as eventLoopDispatch {`EventLoop', `Int'} -> `Result' errToResult#} 164 | 165 | -- | void wl_event_loop_dispatch_idle(struct wl_event_loop *loop); 166 | {#fun event_loop_dispatch_idle as eventLoopDispatchIdle {`EventLoop'} -> `()' #} 167 | 168 | -- | struct wl_event_source *wl_event_loop_add_idle(struct wl_event_loop *loop, 169 | -- wl_event_loop_idle_func_t func, 170 | -- void *data); 171 | {#fun event_loop_add_idle as eventLoopAddIdle {`EventLoop', melif* `EventLoopIdleFunc', withNullPtr- `Ptr ()'} -> `EventSource' #} 172 | 173 | -- | int wl_event_loop_get_fd(struct wl_event_loop *loop); 174 | {#fun unsafe event_loop_get_fd as eventLoopGetFd {`EventLoop'} -> `Fd' Fd #} 175 | 176 | 177 | -- EXPOSED UNTIL HERE 178 | 179 | 180 | -- struct wl_client; 181 | -- defined in .Util 182 | {#pointer * client as Client newtype nocode#} 183 | 184 | receiveMaybeClient :: Client -> Maybe Client 185 | receiveMaybeClient (Client x) 186 | | x == nullPtr = Nothing 187 | | otherwise = Just (Client x) 188 | 189 | -- |struct wl_display; 190 | -- 191 | -- this is called a Compositor in e.g weston, QtWayland 192 | -- 193 | -- this is NOT an instance of a wl_resource or a wl_proxy! it is a global server status singleton listing e.g. connected clients. 194 | {#pointer * display as DisplayServer newtype #} 195 | 196 | -- struct wl_listener; 197 | -- struct wl_resource; 198 | -- struct wl_global; 199 | 200 | -- typedef void (*wl_notify_func_t)(struct wl_listener *listener, void *data); 201 | -- void wl_event_loop_add_destroy_listener(struct wl_event_loop *loop, 202 | -- struct wl_listener * listener); 203 | -- struct wl_listener *wl_event_loop_get_destroy_listener( 204 | -- struct wl_event_loop *loop, 205 | -- wl_notify_func_t notify); 206 | 207 | -- | struct wl_display *wl_display_create(void); 208 | {#fun unsafe display_create as displayCreate {} -> `DisplayServer' #} 209 | 210 | -- | void wl_display_destroy(struct wl_display *display); 211 | {#fun unsafe display_destroy as displayDestroy {`DisplayServer'} -> `()' #} 212 | 213 | -- | struct wl_event_loop *wl_display_get_event_loop(struct wl_display *display); 214 | {#fun unsafe display_get_event_loop as displayGetEventLoop {`DisplayServer'} -> `EventLoop' #} 215 | 216 | -- | int wl_display_add_socket(struct wl_display *display, const char *name); 217 | withMaybeCString :: Maybe String -> (CString -> IO a) -> IO a 218 | withMaybeCString Nothing fun = fun nullPtr 219 | withMaybeCString (Just str) fun = withCString str fun 220 | {#fun unsafe display_add_socket as displayAddSocket {`DisplayServer', withMaybeCString* `Maybe String'} -> `Result' errToResult #} 221 | 222 | -- | void wl_display_terminate(struct wl_display *display); 223 | {#fun unsafe display_terminate as displayTerminate {`DisplayServer'} -> `()' #} 224 | 225 | -- | void wl_display_run(struct wl_display *display); 226 | -- 227 | -- STRICTLY SAFE!!! 228 | {#fun display_run as displayRun {`DisplayServer'} -> `()' #} 229 | 230 | -- | void wl_display_flush_clients(struct wl_display *display); 231 | {#fun display_flush_clients as displayFlushClients {`DisplayServer'} -> `()' #} 232 | 233 | -- typedef void (*wl_global_bind_func_t)(struct wl_client *client, void *data, 234 | -- uint32_t version, uint32_t id); 235 | 236 | -- not sure what these two functions are for 237 | -- | uint32_t wl_display_get_serial(struct wl_display *display); 238 | {#fun unsafe display_get_serial as displayGetSerial {`DisplayServer'} -> `Word' fromIntegral #} 239 | 240 | -- | uint32_t wl_display_next_serial(struct wl_display *display); 241 | {#fun unsafe display_next_serial as displayNextSerial {`DisplayServer'} -> `Word' fromIntegral #} 242 | 243 | -- void wl_display_add_destroy_listener(struct wl_display *display, 244 | -- struct wl_listener *listener); 245 | -- struct wl_listener *wl_display_get_destroy_listener(struct wl_display *display, 246 | -- wl_notify_func_t notify); 247 | 248 | -- struct wl_global *wl_global_create(struct wl_display *display, 249 | -- const struct wl_interface *interface, 250 | -- int version, 251 | -- void *data, wl_global_bind_func_t bind); 252 | -- void wl_global_destroy(struct wl_global *global); 253 | 254 | -- | struct wl_client *wl_client_create(struct wl_display *display, int fd); 255 | {#fun unsafe client_create as clientCreate {`DisplayServer', unFd `Fd'} -> `Maybe Client' receiveMaybeClient #} 256 | 257 | -- | void wl_client_destroy(struct wl_client *client); 258 | {#fun unsafe client_destroy as clientDestroy {`Client'} -> `()' #} 259 | 260 | -- | void wl_client_flush(struct wl_client *client); 261 | {#fun unsafe client_flush as clientFlush {`Client'} -> `()' #} 262 | 263 | peekPid = liftM CPid . liftM fromIntegral . peek 264 | peekUid = liftM CUid . liftM fromIntegral . peek 265 | peekGid = liftM CGid . liftM fromIntegral . peek 266 | -- | void wl_client_get_credentials(struct wl_client *client, 267 | -- pid_t *pid, uid_t *uid, gid_t *gid); 268 | {#fun unsafe client_get_credentials as clientGetCredentials {`Client', alloca- `ProcessID' peekPid*, alloca- `UserID' peekUid*, alloca- `GroupID' peekGid*} -> `()' #} 269 | 270 | -- void wl_client_add_destroy_listener(struct wl_client *client, 271 | -- struct wl_listener *listener); 272 | -- struct wl_listener *wl_client_get_destroy_listener(struct wl_client *client, 273 | -- wl_notify_func_t notify); 274 | 275 | -- this function should not be needed 276 | -- struct wl_resource * 277 | -- wl_client_get_object(struct wl_client *client, uint32_t id); 278 | -- void 279 | -- | wl_client_post_no_memory(struct wl_client *client); 280 | {#fun unsafe client_post_no_memory as clientPostNoMemory {`Client'} -> `()' #} 281 | 282 | -- /** \class wl_listener 283 | -- * 284 | -- * \brief A single listener for Wayland signals 285 | -- * 286 | -- * wl_listener provides the means to listen for wl_signal notifications. Many 287 | -- * Wayland objects use wl_listener for notification of significant events like 288 | -- * object destruction. 289 | -- * 290 | -- * Clients should create wl_listener objects manually and can register them as 291 | -- * listeners to signals using #wl_signal_add, assuming the signal is 292 | -- * directly accessible. For opaque structs like wl_event_loop, adding a 293 | -- * listener should be done through provided accessor methods. A listener can 294 | -- * only listen to one signal at a time. 295 | -- * 296 | -- * ~~~ 297 | -- * struct wl_listener your_listener; 298 | -- * 299 | -- * your_listener.notify = your_callback_method; 300 | -- * 301 | -- * \comment{Direct access} 302 | -- * wl_signal_add(&some_object->destroy_signal, &your_listener); 303 | -- * 304 | -- * \comment{Accessor access} 305 | -- * wl_event_loop *loop = ...; 306 | -- * wl_event_loop_add_destroy_listener(loop, &your_listener); 307 | -- * ~~~ 308 | -- * 309 | -- * If the listener is part of a larger struct, #wl_container_of can be used 310 | -- * to retrieve a pointer to it: 311 | -- * 312 | -- * \code 313 | -- * void your_listener(struct wl_listener *listener, void *data) 314 | -- * { 315 | -- * struct your_data *data; 316 | -- * 317 | -- * your_data = wl_container_of(listener, data, your_member_name); 318 | -- * } 319 | -- * \endcode 320 | -- * 321 | -- * If you need to remove a listener from a signal, use #wl_list_remove. 322 | -- * 323 | -- * \code 324 | -- * wl_list_remove(&your_listener.link); 325 | -- * \endcode 326 | -- * 327 | -- * \sa wl_signal 328 | -- */ 329 | -- struct wl_listener { 330 | -- struct wl_list link; 331 | -- wl_notify_func_t notify; 332 | -- }; 333 | 334 | -- /** \class wl_signal 335 | -- * 336 | -- * \brief A source of a type of observable event 337 | -- * 338 | -- * Signals are recognized points where significant events can be observed. 339 | -- * Compositors as well as the server can provide signals. Observers are 340 | -- * wl_listener's that are added through #wl_signal_add. Signals are emitted 341 | -- * using #wl_signal_emit, which will invoke all listeners until that 342 | -- * listener is removed by #wl_list_remove (or whenever the signal is 343 | -- * destroyed). 344 | -- * 345 | -- * \sa wl_listener for more information on using wl_signal 346 | -- */ 347 | -- struct wl_signal { 348 | -- struct wl_list listener_list; 349 | -- }; 350 | 351 | -- /** Initialize a new \ref wl_signal for use. 352 | -- * 353 | -- * \param signal The signal that will be initialized 354 | -- * 355 | -- * \memberof wl_signal 356 | -- */ 357 | -- static inline void 358 | -- wl_signal_init(struct wl_signal *signal) 359 | -- { 360 | -- wl_list_init(&signal->listener_list); 361 | -- } 362 | 363 | -- /** Add the specified listener to this signal. 364 | -- * 365 | -- * \param signal The signal that will emit events to the listener 366 | -- * \param listener The listener to add 367 | -- * 368 | -- * \memberof wl_signal 369 | -- */ 370 | -- static inline void 371 | -- wl_signal_add(struct wl_signal *signal, struct wl_listener *listener) 372 | -- { 373 | -- wl_list_insert(signal->listener_list.prev, &listener->link); 374 | -- } 375 | 376 | -- /** Gets the listener struct for the specified callback. 377 | -- * 378 | -- * \param signal The signal that contains the specified listener 379 | -- * \param notify The listener that is the target of this search 380 | -- * \return the list item that corresponds to the specified listener, or NULL 381 | -- * if none was found 382 | -- * 383 | -- * \memberof wl_signal 384 | -- */ 385 | -- static inline struct wl_listener * 386 | -- wl_signal_get(struct wl_signal *signal, wl_notify_func_t notify) 387 | -- { 388 | -- struct wl_listener *l; 389 | 390 | -- wl_list_for_each(l, &signal->listener_list, link) 391 | -- if (l->notify == notify) 392 | -- return l; 393 | 394 | -- return NULL; 395 | -- } 396 | 397 | -- /** Emits this signal, notifying all registered listeners. 398 | -- * 399 | -- * \param signal The signal object that will emit the signal 400 | -- * \param data The data that will be emitted with the signal 401 | -- * 402 | -- * \memberof wl_signal 403 | -- */ 404 | -- static inline void 405 | -- wl_signal_emit(struct wl_signal *signal, void *data) 406 | -- { 407 | -- struct wl_listener *l, *next; 408 | 409 | -- wl_list_for_each_safe(l, next, &signal->listener_list, link) 410 | -- l->notify(l, data); 411 | -- } 412 | 413 | -- typedef void (*wl_resource_destroy_func_t)(struct wl_resource *resource); 414 | 415 | -- NOTE not binding to deprecated stuff, cause wayland is bad enough as it is. 416 | 417 | -- /* 418 | -- * Post an event to the client's object referred to by 'resource'. 419 | -- * 'opcode' is the event number generated from the protocol XML 420 | -- * description (the event name). The variable arguments are the event 421 | -- * parameters, in the order they appear in the protocol XML specification. 422 | -- * 423 | -- * The variable arguments' types are: 424 | -- * - type=uint: uint32_t 425 | -- * - type=int: int32_t 426 | -- * - type=fixed: wl_fixed_t 427 | -- * - type=string: (const char *) to a nil-terminated string 428 | -- * - type=array: (struct wl_array *) 429 | -- * - type=fd: int, that is an open file descriptor 430 | -- * - type=new_id: (struct wl_object *) or (struct wl_resource *) 431 | -- * - type=object: (struct wl_object *) or (struct wl_resource *) 432 | -- */ 433 | -- void wl_resource_post_event(struct wl_resource *resource, 434 | -- uint32_t opcode, ...); 435 | -- void wl_resource_post_event_array(struct wl_resource *resource, 436 | -- uint32_t opcode, union wl_argument *args); 437 | -- void wl_resource_queue_event(struct wl_resource *resource, 438 | -- uint32_t opcode, ...); 439 | -- void wl_resource_queue_event_array(struct wl_resource *resource, 440 | -- uint32_t opcode, union wl_argument *args); 441 | 442 | -- /* msg is a printf format string, variable args are its args. */ 443 | -- void wl_resource_post_error(struct wl_resource *resource, 444 | -- uint32_t code, const char *msg, ...) 445 | -- __attribute__ ((format (printf, 3, 4))); 446 | -- void wl_resource_post_no_memory(struct wl_resource *resource); 447 | 448 | -- #include "wayland-server-protocol.h" 449 | 450 | -- struct wl_display * 451 | -- wl_client_get_display(struct wl_client *client); 452 | 453 | -- struct wl_resource * 454 | -- wl_resource_create(struct wl_client *client, 455 | -- const struct wl_interface *interface, 456 | -- int version, uint32_t id); 457 | -- void 458 | -- wl_resource_set_implementation(struct wl_resource *resource, 459 | -- const void *implementation, 460 | -- void *data, 461 | -- wl_resource_destroy_func_t destroy); 462 | -- void 463 | -- wl_resource_set_dispatcher(struct wl_resource *resource, 464 | -- wl_dispatcher_func_t dispatcher, 465 | -- const void *implementation, 466 | -- void *data, 467 | -- wl_resource_destroy_func_t destroy); 468 | 469 | -- void 470 | -- wl_resource_destroy(struct wl_resource *resource); 471 | -- uint32_t 472 | -- wl_resource_get_id(struct wl_resource *resource); 473 | -- struct wl_list * 474 | -- wl_resource_get_link(struct wl_resource *resource); 475 | -- struct wl_resource * 476 | -- wl_resource_from_link(struct wl_list *resource); 477 | -- struct wl_resource * 478 | -- wl_resource_find_for_client(struct wl_list *list, struct wl_client *client); 479 | -- struct wl_client * 480 | -- wl_resource_get_client(struct wl_resource *resource); 481 | -- void 482 | -- wl_resource_set_user_data(struct wl_resource *resource, void *data); 483 | -- void * 484 | -- wl_resource_get_user_data(struct wl_resource *resource); 485 | -- int 486 | -- wl_resource_get_version(struct wl_resource *resource); 487 | -- void 488 | -- wl_resource_set_destructor(struct wl_resource *resource, 489 | -- wl_resource_destroy_func_t destroy); 490 | -- int 491 | -- wl_resource_instance_of(struct wl_resource *resource, 492 | -- const struct wl_interface *interface, 493 | -- const void *implementation); 494 | 495 | -- void 496 | -- wl_resource_add_destroy_listener(struct wl_resource *resource, 497 | -- struct wl_listener * listener); 498 | -- struct wl_listener * 499 | -- wl_resource_get_destroy_listener(struct wl_resource *resource, 500 | -- wl_notify_func_t notify); 501 | 502 | -- #define wl_resource_for_each(resource, list) \ 503 | -- for (resource = 0, resource = wl_resource_from_link((list)->next); \ 504 | -- wl_resource_get_link(resource) != (list); \ 505 | -- resource = wl_resource_from_link(wl_resource_get_link(resource)->next)) 506 | 507 | -- #define wl_resource_for_each_safe(resource, tmp, list) \ 508 | -- for (resource = 0, tmp = 0, \ 509 | -- resource = wl_resource_from_link((list)->next), \ 510 | -- tmp = wl_resource_from_link((list)->next->next); \ 511 | -- wl_resource_get_link(resource) != (list); \ 512 | -- resource = tmp, \ 513 | -- tmp = wl_resource_from_link(wl_resource_get_link(resource)->next)) 514 | 515 | 516 | -- this is a dirty hack to make shmBufferGet accept a Buffer 517 | {#pointer * resource as Buffer newtype nocode#} 518 | -- struct wl_shm_buffer; 519 | {#pointer * shm_buffer as ShmBuffer newtype#} 520 | receiveMaybeShmBuffer :: ShmBuffer -> Maybe ShmBuffer 521 | receiveMaybeShmBuffer (ShmBuffer x) 522 | | x == nullPtr = Nothing 523 | | otherwise = Just (ShmBuffer x) 524 | 525 | -- | void 526 | -- wl_shm_buffer_begin_access(struct wl_shm_buffer *buffer); 527 | -- 528 | -- Lock the memory for reading. Needed to protect the server against SIGBUS signals 529 | -- caused by the client resizing the buffer. 530 | {#fun unsafe shm_buffer_begin_access as shmBufferBeginAccess {`ShmBuffer'} -> `()' #} 531 | 532 | -- |void 533 | -- wl_shm_buffer_end_access(struct wl_shm_buffer *buffer); 534 | -- 535 | -- Unlock the memory. 536 | {#fun unsafe shm_buffer_end_access as shmBufferEndAccess {`ShmBuffer'} -> `()' #} 537 | 538 | -- | struct wl_shm_buffer * 539 | -- wl_shm_buffer_get(struct wl_resource *resource); 540 | {#fun unsafe shm_buffer_get as shmBufferGet {`Buffer'} -> `Maybe ShmBuffer' receiveMaybeShmBuffer #} 541 | 542 | -- | void * 543 | -- wl_shm_buffer_get_data(struct wl_shm_buffer *buffer); 544 | {#fun unsafe shm_buffer_get_data as shmBufferGetData {`ShmBuffer'} -> `Ptr ()' id #} 545 | 546 | -- | int32_t 547 | -- wl_shm_buffer_get_stride(struct wl_shm_buffer *buffer); 548 | {#fun unsafe shm_buffer_get_stride as shmBufferGetStride {`ShmBuffer'} -> `Int' #} 549 | 550 | -- | uint32_t 551 | -- wl_shm_buffer_get_format(struct wl_shm_buffer *buffer); 552 | {#fun unsafe shm_buffer_get_format as shmBufferGetFormat {`ShmBuffer'} -> `Word' fromIntegral#} 553 | 554 | -- | int32_t 555 | -- wl_shm_buffer_get_width(struct wl_shm_buffer *buffer); 556 | {#fun unsafe shm_buffer_get_width as shmBufferGetWidth {`ShmBuffer'} -> `Int' #} 557 | 558 | -- | int32_t 559 | -- wl_shm_buffer_get_height(struct wl_shm_buffer *buffer); 560 | {#fun unsafe shm_buffer_get_height as shmBufferGetHeight {`ShmBuffer'} -> `Int' #} 561 | 562 | -- | int 563 | -- wl_display_init_shm(struct wl_display *display); 564 | {#fun unsafe display_init_shm as displayInitShm {`DisplayServer'} -> `Result' errToResult #} 565 | 566 | -- | uint32_t * 567 | -- wl_display_add_shm_format(struct wl_display *display, uint32_t format); 568 | {#fun unsafe display_add_shm_format as displayAddShmFormat {`DisplayServer', fromIntegral `Word'} -> `()' #} 569 | 570 | -- | struct wl_shm_buffer * 571 | -- wl_shm_buffer_create(struct wl_client *client, 572 | -- uint32_t id, int32_t width, int32_t height, 573 | -- int32_t stride, uint32_t format); 574 | {#fun unsafe shm_buffer_create as shmBufferCreate {`Client', fromIntegral `Word', fromIntegral `Word', `Int', `Int', fromIntegral `Word'} -> `Maybe ShmBuffer' receiveMaybeShmBuffer#} 575 | 576 | -- void wl_log_set_handler_server(wl_log_func_t handler); 577 | -------------------------------------------------------------------------------- /Graphics/Wayland/Internal/ServerClientState.chs: -------------------------------------------------------------------------------- 1 | module Graphics.Wayland.Internal.ServerClientState where 2 | 3 | #include 4 | 5 | {#enum define ClientStateNums { 6 | WL_EVENT_READABLE as ClientReadable, 7 | WL_EVENT_WRITABLE as ClientWritable, 8 | WL_EVENT_HANGUP as ClientHangup, 9 | WL_EVENT_ERROR as ClientError} #} -------------------------------------------------------------------------------- /Graphics/Wayland/Internal/SpliceClient.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell, ForeignFunctionInterface #-} 2 | 3 | module Graphics.Wayland.Internal.SpliceClient where 4 | 5 | import Data.Functor 6 | import Language.Haskell.TH 7 | import Foreign.C.Types 8 | 9 | import Graphics.Wayland.Scanner.Protocol 10 | import Graphics.Wayland.Scanner 11 | import Graphics.Wayland.Internal.SpliceClientTypes 12 | import qualified Graphics.Wayland.Internal.SpliceClientInternal as Import 13 | 14 | 15 | $(runIO readProtocol >>= generateClientExports) 16 | -------------------------------------------------------------------------------- /Graphics/Wayland/Internal/SpliceClientInternal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell, ForeignFunctionInterface #-} 2 | 3 | module Graphics.Wayland.Internal.SpliceClientInternal where 4 | 5 | import Data.Functor 6 | import Language.Haskell.TH 7 | import Foreign.C.Types 8 | 9 | import Graphics.Wayland.Scanner.Protocol 10 | import Graphics.Wayland.Scanner 11 | import Graphics.Wayland.Internal.SpliceClientTypes 12 | 13 | 14 | $(runIO readProtocol >>= generateClientInternal) 15 | -------------------------------------------------------------------------------- /Graphics/Wayland/Internal/SpliceClientTypes.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell, ForeignFunctionInterface #-} 2 | 3 | module Graphics.Wayland.Internal.SpliceClientTypes where 4 | 5 | import Data.Functor 6 | import Language.Haskell.TH 7 | import Foreign.C.Types 8 | 9 | import Graphics.Wayland.Scanner.Protocol 10 | import Graphics.Wayland.Scanner 11 | 12 | $(runIO readProtocol >>= generateClientTypes) 13 | -------------------------------------------------------------------------------- /Graphics/Wayland/Internal/SpliceServer.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell, ForeignFunctionInterface #-} 2 | 3 | module Graphics.Wayland.Internal.SpliceServer where 4 | 5 | import Data.Functor 6 | import Language.Haskell.TH 7 | import Foreign.C.Types 8 | 9 | import Graphics.Wayland.Scanner.Protocol 10 | import Graphics.Wayland.Scanner 11 | import qualified Graphics.Wayland.Internal.SpliceServerInternal as Import 12 | 13 | 14 | $(runIO readProtocol >>= generateServerExports) 15 | -------------------------------------------------------------------------------- /Graphics/Wayland/Internal/SpliceServerInternal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell, ForeignFunctionInterface #-} 2 | 3 | module Graphics.Wayland.Internal.SpliceServerInternal where 4 | 5 | import Data.Functor 6 | import Language.Haskell.TH 7 | import Foreign.C.Types 8 | 9 | import Graphics.Wayland.Scanner.Protocol 10 | import Graphics.Wayland.Scanner 11 | import Graphics.Wayland.Internal.Util 12 | import Graphics.Wayland.Internal.SpliceServerTypes 13 | 14 | 15 | $(runIO readProtocol >>= generateServerInternal) 16 | -------------------------------------------------------------------------------- /Graphics/Wayland/Internal/SpliceServerTypes.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell, ForeignFunctionInterface #-} 2 | 3 | module Graphics.Wayland.Internal.SpliceServerTypes where 4 | 5 | import Data.Functor 6 | import Language.Haskell.TH 7 | import Foreign.C.Types 8 | 9 | import Graphics.Wayland.Scanner.Protocol 10 | import Graphics.Wayland.Scanner 11 | 12 | $(runIO readProtocol >>= generateServerTypes) 13 | -------------------------------------------------------------------------------- /Graphics/Wayland/Internal/Util.chs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | module Graphics.Wayland.Internal.Util ( 3 | CInterface(..), Client(..), 4 | 5 | Fixed256, Precision256, 6 | 7 | Time, millisecondsToTime, timeToMilliseconds, diffTimeToTime, timeToDiffTime 8 | ) where 9 | 10 | import Data.Ratio ((%)) 11 | import Data.Time.Clock (DiffTime) 12 | import Data.Fixed (Fixed(..), HasResolution(..), Milli(..)) 13 | import Data.Typeable 14 | import Data.Functor 15 | import Foreign 16 | import Foreign.C.Types 17 | import Foreign.C.String 18 | 19 | #include 20 | #include 21 | 22 | {#context prefix="wl"#} 23 | 24 | 25 | -- | struct wl_interface pointer 26 | {#pointer * interface as CInterface newtype#} 27 | 28 | 29 | 30 | -- | opaque server-side wl_client struct 31 | newtype Client = Client (Ptr Client) deriving (Eq) 32 | 33 | -- | 8 bits of precision means a resolution of 256. 34 | data Precision256 = Precision256 deriving (Typeable) 35 | instance HasResolution Precision256 where 36 | resolution _ = 256 37 | -- | Fixed point number with 8 bits of decimal precision. 38 | -- 39 | -- The equivalent of wayland's wl_fixed_t. 40 | type Fixed256 = Fixed Precision256 41 | 42 | -- | Represents time in seconds with millisecond precision. 43 | -- 44 | -- 45 | type Time = Milli 46 | 47 | millisecondsToTime :: CUInt -> Time 48 | millisecondsToTime = MkFixed . fromIntegral 49 | timeToMilliseconds :: Time -> CUInt 50 | timeToMilliseconds (MkFixed n) = fromIntegral n 51 | 52 | timeToDiffTime :: Time -> DiffTime 53 | timeToDiffTime (MkFixed n) = fromRational (n % 1000) 54 | 55 | diffTimeToTime :: DiffTime -> Time 56 | diffTimeToTime = fromRational . toRational 57 | -------------------------------------------------------------------------------- /Graphics/Wayland/Internal/Version.chs: -------------------------------------------------------------------------------- 1 | module Graphics.Wayland.Internal.Version (version) where 2 | 3 | #include 4 | 5 | {#enum define VersionInt {WAYLAND_VERSION_MAJOR as MajorInt, WAYLAND_VERSION_MINOR as MinorInt, WAYLAND_VERSION_MICRO as MicroInt} deriving (Eq, Ord) #} 6 | 7 | version = (fromEnum MajorInt, fromEnum MinorInt, fromEnum MicroInt) 8 | -------------------------------------------------------------------------------- /Graphics/Wayland/Scanner.chs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | 3 | module Graphics.Wayland.Scanner ( 4 | generateClientTypes, 5 | generateClientInternal, 6 | generateClientExports, 7 | 8 | generateServerTypes, 9 | generateServerInternal, 10 | generateServerExports, 11 | 12 | module Graphics.Wayland.Scanner.Types, 13 | module Graphics.Wayland.Scanner.Protocol, 14 | 15 | CInterface(..) 16 | 17 | ) where 18 | 19 | import Data.Functor ((<$>)) 20 | import Data.Either (lefts, rights) 21 | import Data.Maybe (fromJust) 22 | import Data.List (findIndex) 23 | import Control.Monad (liftM) 24 | import Control.Monad.Trans.Class (lift) 25 | import Control.Monad.Trans.Writer (tell, WriterT, runWriterT) 26 | import Foreign 27 | import Foreign.C.Types 28 | import Foreign.C.String (withCString) 29 | import Language.Haskell.TH 30 | import Language.Haskell.TH.Syntax (VarStrictType) 31 | 32 | import Graphics.Wayland 33 | import Graphics.Wayland.Scanner.Marshaller 34 | import Graphics.Wayland.Scanner.Names 35 | import Graphics.Wayland.Scanner.Protocol 36 | import Graphics.Wayland.Scanner.Types 37 | import Graphics.Wayland.Internal.Util hiding (Client) 38 | import qualified Graphics.Wayland.Internal.Util as Util (Client) 39 | 40 | 41 | -- Dear future maintainer, 42 | -- I'm sorry. 43 | 44 | 45 | #include 46 | 47 | 48 | -- | We will be working in this monad to generate binding code and simultaneously 49 | -- remember which symbols should be exported by the library. 50 | type ProcessWithExports a = WriterT [String] Q a 51 | 52 | -- | Remember that we should re-export this symbol so that it is usable 53 | export :: String -> ProcessWithExports () 54 | export name = tell [name] 55 | 56 | -- | Wayland data types - exported in the Internal.{Client,Server}Types modules 57 | generateDataTypes :: ProtocolSpec -> Q [Dec] 58 | generateDataTypes ps = liftM concat $ sequence $ map generateInterface (protocolInterfaces ps) where 59 | generateInterface :: Interface -> Q [Dec] 60 | generateInterface iface = do 61 | let iname = interfaceName iface 62 | pname = protocolName ps 63 | qname = interfaceTypeName pname iname 64 | constructorType <- [t|$(conT ''Ptr) $(conT $ mkName qname)|] 65 | typeDec <- newtypeD (return []) (mkName qname) [] (normalC (mkName qname) [return (NotStrict, constructorType)]) [mkName "Show", mkName "Eq"] 66 | 67 | versionInstance <- [d| 68 | instance ProtocolVersion $(conT $ mkName qname) where 69 | protocolVersion _ = $(litE $ IntegerL $ fromIntegral $ interfaceVersion iface) 70 | |] 71 | 72 | return $ typeDec : versionInstance 73 | 74 | -- | The wayland registry allows one to construct global objects. 75 | -- Its API is in wayland.xml, but that API is type-unsafe, so we construct the 76 | -- the bindings explicitly here. 77 | generateRegistryBind :: ProtocolSpec -> ProcessWithExports [Dec] 78 | generateRegistryBind ps = do 79 | -- We should only be able to construct "global" objects, which are those that cannot be obtained via other objects. 80 | -- The following code picks out these global interfaces. 81 | let messageCreatesIface child msg = any (\ argument -> 82 | case argument of 83 | (_, NewIdArg _ x, _) -> x == interfaceName child 84 | _ -> False) 85 | (messageArguments msg) 86 | interfaceCreatesIface child parent = any (messageCreatesIface child) (interfaceRequests parent) 87 | protocolCreatesIface child = any (interfaceCreatesIface child) (protocolInterfaces ps) 88 | globalInterfaces = filter (not.protocolCreatesIface) $ filter (\iface -> interfaceName iface /= "wl_display") (protocolInterfaces ps) 89 | 90 | -- From the wayland header files (for reference): 91 | -- static inline void * wl_registry_bind(struct wl_registry *wl_registry, uint32_t name, const struct wl_interface *interface, uint32_t version) 92 | -- id = wl_proxy_marshal_constructor((struct wl_proxy *) wl_registry, WL_REGISTRY_BIND, interface, name, interface->name, version, NULL); 93 | -- struct wl_proxy * wl_proxy_marshal_constructor(struct wl_proxy *proxy, uint32_t opcode, const struct wl_interface *interface, ...) 94 | liftM concat $ sequence $ map registryBindInterface globalInterfaces 95 | where 96 | registryBindInterface :: Interface -> ProcessWithExports [Dec] 97 | registryBindInterface iface = do 98 | let iname = interfaceName iface 99 | pname = protocolName ps 100 | internalCName = mkName $ "wl_registry_" ++ iname ++ "_c_bind" 101 | exposeName = registryBindName pname iname 102 | 103 | fore <- lift $ forImpD cCall unsafe "wl_proxy_marshal_constructor" internalCName [t|$(conT $ mkName "Registry") -> {#type uint32_t#} -> CInterface -> CUInt -> Ptr CChar -> CUInt -> Ptr () -> IO $(conT $ mkName $ interfaceTypeName pname iname) |] 104 | exposureDec <- lift $ 105 | [d| 106 | $(varP $ mkName exposeName) = 107 | \ reg name strname version -> 108 | withCString strname $ 109 | \ cstr -> 110 | $(varE internalCName) 111 | reg 112 | 0 113 | $(varE $ interfaceCInterfaceName pname iname) 114 | (fromIntegral (name::Word)) 115 | cstr 116 | (fromIntegral (version::Word)) 117 | nullPtr 118 | |] 119 | export exposeName 120 | return $ fore : exposureDec 121 | 122 | 123 | -- | Wayland has an "enum" type argument for messages. Here, we generate the corresponding Haskell types. 124 | -- 125 | -- Note that wayland-style enums might not actually be enums, in the sense that they are sometimes 126 | -- actually bit fields. 127 | generateEnums :: ProtocolSpec -> Q [Dec] 128 | generateEnums ps = return $ concat $ map eachGenerateEnums (protocolInterfaces ps) where 129 | eachGenerateEnums :: Interface -> [Dec] 130 | eachGenerateEnums iface = concat $ map generateEnum $ interfaceEnums iface where 131 | generateEnum :: WLEnum -> [Dec] 132 | generateEnum wlenum = 133 | let qname = enumTypeName (protocolName ps) (interfaceName iface) (enumName wlenum) 134 | in 135 | NewtypeD [] qname [] (NormalC qname [(NotStrict, (ConT ''Int))]) [mkName "Show", mkName "Eq"] 136 | : 137 | map (\(entry, val) -> (ValD (VarP $ enumEntryHaskName (protocolName ps) (interfaceName iface) (enumName wlenum) entry) (NormalB $ (ConE qname) `AppE` (LitE $ IntegerL $ toInteger val)) [])) (enumEntries wlenum) 138 | 139 | -- | We will need a pointer to the wl_interface structs, for passing to wl_proxy_marshal_constructor and wl_resource_create. 140 | -- Now, a pretty solution would construct its own wl_interface struct here. 141 | -- But that's way too much work for me. We just bind to the one generated by the C scanner. 142 | generateCInterfaceDecs :: ProtocolSpec -> Q [Dec] 143 | generateCInterfaceDecs ps = mapM bindCInterface (protocolInterfaces ps) 144 | where 145 | bindCInterface :: Interface -> Q Dec 146 | bindCInterface iface = 147 | forImpD 148 | cCall 149 | unsafe 150 | ("&"++ (interfaceName iface) ++ "_interface") 151 | (interfaceCInterfaceName (protocolName ps) (interfaceName iface) ) 152 | [t| (CInterface)|] -- pointer is fixed 153 | 154 | -- | This function generates bindings to the "core" message passing API: 155 | -- it binds to the actual message senders. 156 | generateMethods :: ProtocolSpec -> ServerClient -> ProcessWithExports [Dec] 157 | generateMethods ps sc = liftM concat $ sequence $ map generateInterface $ filter (\iface -> if sc == Server then interfaceName iface /= "wl_display" else True) $ protocolInterfaces ps where 158 | generateInterface :: Interface -> ProcessWithExports [Dec] 159 | generateInterface iface = do 160 | -- Okay, we have to figure out some stuff. There is a tree of possibilities: 161 | -- - Server 162 | -- => this is actually an easy case. every message is just some call to wl_resource_post_event 163 | -- - Client 164 | -- - - if a message has more than one new_id argument, skip (or undefined for safety?) 165 | -- - - if a message has a single untyped new_id argument (ie now interface attribute in the XML), then there is some complicated C implementation we won't be copying, skip 166 | -- - - if a message has a single typed new_id argument, then this is the return value of wl_proxy_marshal_constructor 167 | -- => pass a bunch of constants in the initial arguments. pass NULL in its argument position 168 | -- - - if a message has no new_id arguments, we are calling wl_proxy_marshal 169 | -- => for each argument EXCEPT new_id's(where we would pass NULL as discussed), pass that argument 170 | -- Note that wl_resource_post_event, wl_proxy_marshal and wl_proxy_marshal_constructor all have the message index in the SECOND position: the object corresponding to the message is the first! So the important thing to remember is that our pretty Haskell function representations have some arguments inserted in between. 171 | -- 172 | -- Further, in the Client case, we have to make a destructor. Some messages can have type="destructor" in the XML protocol files. 173 | -- - there is no message typed destructor with name "destroy" 174 | -- - - if the interface is wl_display, don't do anything 175 | -- - - if the interface is NOT wl_display 176 | -- => generate a new function "destroy", a synonnym for wl_proxy_destroy 177 | -- - otherwise, for each message typed destructor (possibly including "destroy") 178 | -- => call wl_proxy_marshal as normal, and *also* wl_proxy_destroy on this proxy (sole argument) 179 | -- - the case of having a "destroy", but no destructor, is illegal: iow, if you have a "destroy", then you must also have a destructor request. 180 | -- the C scanner allows you to have a non-destructor "destroy", but I doubt that's the intention, so I'll make that undefined. 181 | -- "dirty" name of internal raw binding to C function 182 | 183 | -- bind object destroyers 184 | let destroyName = mkName $ interfaceName iface ++ "_destructor" 185 | needsDefaultDestructor = ((sc == Client) && (not $ any messageIsDestructor $ interfaceRequests iface) && (interfaceName iface /= "wl_display")) 186 | defaultDestructorName = requestHaskName (protocolName ps) (interfaceName iface) "destroy" 187 | foreignDestructor <- lift $ forImpD cCall unsafe "wl_proxy_destroy" destroyName [t|$(conT $ mkName $ interfaceTypeName (protocolName ps) (interfaceName iface)) -> IO ()|] 188 | -- FIXME: in the destructors, we should additionally clean up memory allocated for the callback infrastructure 189 | -- This should happen in the default destructor here and in any other destructor-type message below. 190 | defaultDestructor <- lift $ [d|$(varP $ mkName defaultDestructorName) = \ proxy -> $(varE destroyName) proxy|] 191 | if needsDefaultDestructor 192 | then export defaultDestructorName 193 | else return () 194 | 195 | let 196 | -- Bind to an individual message 197 | generateMessage :: Int -> Message -> ProcessWithExports [Dec] 198 | generateMessage idx msg = -- index in the list used for wl_proxy_marshal arguments 199 | let pname = protocolName ps 200 | iname = interfaceName iface 201 | mname = messageName msg 202 | 203 | hname = case sc of 204 | Server -> eventHaskName pname iname mname 205 | Client -> requestHaskName pname iname mname 206 | internalCName = case sc of 207 | Server -> mkName $ "wl_rpe_" ++ interfaceName iface ++ "_" ++ messageName msg 208 | Client -> mkName $ "wl_pm_" ++ interfaceName iface ++ "_" ++ messageName msg 209 | 210 | in case sc of 211 | Server -> do 212 | -- From the wayland header files: 213 | -- void wl_resource_post_event(struct wl_resource *resource, uint32_t opcode, ...); 214 | cdec <- lift $ forImpD cCall unsafe "wl_resource_post_event" internalCName [t|$(conT $ mkName $ interfaceTypeName (protocolName ps) (interfaceName iface)) -> {#type uint32_t#} -> $(genMessageCType Nothing (messageArguments msg)) |] 215 | resourceName <- lift $ newName "resourceInternalName___" 216 | let messageIndexApplied = applyAtPosition (varE internalCName) (litE $ IntegerL $ fromIntegral idx) 1 217 | resourceApplied = [e|$messageIndexApplied $(varE resourceName)|] 218 | (pats,fun) = argTypeMarshaller (messageArguments msg) resourceApplied 219 | declist <- lift $ [d|$(varP $ mkName hname) = $(LamE (VarP resourceName : pats) <$> fun)|] 220 | export hname 221 | return (cdec : declist) 222 | Client -> do 223 | -- See tree of possibilities above 224 | let numNewIds = sum $ map (fromEnum . isNewId) $ messageArguments msg 225 | argsWithoutNewId = filter (\arg -> not $ isNewId arg) (messageArguments msg) 226 | returnArgument = head $ filter (\arg -> isNewId arg) (messageArguments msg) 227 | returnName = let (_, NewIdArg _ theName, _) = returnArgument 228 | in theName 229 | returnType = [t|IO $(argTypeToCType returnArgument)|] 230 | cdec <- lift $ case numNewIds of 231 | -- void wl_proxy_marshal(struct wl_proxy *proxy, uint32_t opcode, ...) 232 | 0 -> forImpD cCall unsafe "wl_proxy_marshal" internalCName [t|$(conT $ mkName $ interfaceTypeName (protocolName ps) (interfaceName iface)) -> {#type uint32_t#} -> $(genMessageCType Nothing (messageArguments msg)) |] 233 | -- struct wl_proxy * wl_proxy_marshal_constructor(struct wl_proxy *proxy, uint32_t opcode, const struct wl_interface *interface, ...) 234 | 1 -> forImpD cCall unsafe "wl_proxy_marshal_constructor" internalCName [t|$(conT $ mkName $ interfaceTypeName (protocolName ps) (interfaceName iface)) -> {#type uint32_t#} -> CInterface -> $(genMessageCType (Just returnType) (messageArguments msg)) |] 235 | 236 | 237 | proxyName <- lift $ newName "proxyInternalName___" 238 | let messageIndexApplied = applyAtPosition (varE internalCName) (litE $ IntegerL $ fromIntegral idx) 1 239 | constructorApplied = case numNewIds of 240 | 0 -> messageIndexApplied 241 | 1 -> applyAtPosition messageIndexApplied (varE $ interfaceCInterfaceName pname (returnName)) 1 242 | proxyApplied = [e|$constructorApplied $(varE proxyName)|] 243 | makeArgumentNullPtr = 244 | let argIdx = fromJust $ findIndex isNewId (messageArguments msg) 245 | arg' = (messageArguments msg) !! argIdx 246 | msgName = let (_,NewIdArg itsname _,_) = arg' 247 | in itsname 248 | in [e|$(conE msgName) nullPtr|] 249 | newIdNullInserted = case numNewIds of 250 | 0 -> proxyApplied 251 | 1 -> applyAtPosition proxyApplied makeArgumentNullPtr (fromJust $ findIndex isNewId (messageArguments msg)) 252 | finalCall = newIdNullInserted 253 | (pats, fun) = argTypeMarshaller (argsWithoutNewId) finalCall 254 | declist <- lift $ [d|$(varP $ mkName hname) = $(LamE (VarP proxyName : pats) <$> [e|do 255 | -- Let's start by either calling wl_proxy_marshal or wl_proxy_marshal_constructor 256 | retval <- $fun 257 | 258 | -- possibly do some destruction here? 259 | $(case messageIsDestructor msg of 260 | False -> [e|return retval|] -- do nothing (will hopefully get optimized away) 261 | True -> [e|$(varE destroyName) $(varE proxyName) |] 262 | ) 263 | 264 | return retval 265 | |])|] 266 | 267 | export hname 268 | return (cdec : declist) 269 | 270 | -- collect all message bindings for a given interface 271 | theMessages <- liftM concat $ sequence $ zipWith generateMessage [0..] $ 272 | case sc of 273 | Server -> interfaceEvents iface 274 | Client -> interfaceRequests iface 275 | 276 | return $ foreignDestructor : theMessages ++ if needsDefaultDestructor then defaultDestructor else [] 277 | 278 | applyAtPosition :: ExpQ -> ExpQ -> Int -> ExpQ 279 | applyAtPosition fun arg pos = do 280 | vars <- sequence $ map (\ _ -> newName "somesecretnameyoushouldntmesswith___") [0..(pos-1)] 281 | lamE (map varP vars) $ 282 | appsE $ fun : (map varE vars) ++ [arg] 283 | 284 | preComposeAt :: ExpQ -> ExpQ -> Int -> Int -> ExpQ 285 | preComposeAt fun arg pos numArgs 286 | | pos > numArgs = error "programming error" 287 | preComposeAt fun arg pos numArgs = do 288 | vars <- sequence $ map (\ _ -> newName "yetanothernewvariablepleasedonttouchme___") [0..numArgs] 289 | lamE (map varP vars) $ 290 | [e|do 291 | preCompVal <- $arg $(varE $ vars !! pos) 292 | $(appsE $ fun : (map varE $ take pos vars) ++ varE 'preCompVal : (map varE $ drop (pos+1) vars)) 293 | |] 294 | 295 | -- | Wayland stores callback functions in a C struct. Here we generate the 296 | -- Haskell equivalent of those structs. 297 | generateListenerTypes :: ProtocolSpec -> ServerClient -> Q [Dec] 298 | generateListenerTypes sp sc = sequence $ map generateListenerType $ 299 | filter (\iface -> 0 < (length $ case sc of 300 | Server -> interfaceRequests iface 301 | Client -> interfaceEvents iface)) $ protocolInterfaces sp 302 | where 303 | generateListenerType :: Interface -> Q Dec 304 | generateListenerType iface = do 305 | let 306 | messages :: [Message] 307 | messages = case sc of 308 | Server -> interfaceRequests iface 309 | Client -> interfaceEvents iface 310 | pname = protocolName sp 311 | iname = interfaceName iface 312 | typeName :: Name 313 | typeName = messageListenerTypeName sc pname iname 314 | mkListenerType :: Message -> TypeQ 315 | mkListenerType msg = case sc of 316 | Server -> [t|Util.Client -> $(conT $ mkName $ interfaceTypeName pname iname) -> $(genMessageHaskType Nothing $ messageArguments msg)|] -- see large comment above 317 | Client -> [t|$(conT $ mkName $ interfaceTypeName pname iname) -> $(genMessageHaskType Nothing $ messageArguments msg)|] 318 | mkMessageName :: Message -> String 319 | mkMessageName msg = messageListenerMessageName sc pname iname (messageName msg) 320 | mkListenerConstr :: Message -> VarStrictTypeQ 321 | mkListenerConstr msg = do 322 | let name = mkName $ mkMessageName msg 323 | ltype <- mkListenerType msg 324 | return (name, NotStrict, ltype) 325 | recArgs <- sequence $ map mkListenerConstr messages 326 | return $ DataD [] typeName [] [RecC typeName recArgs] [] 327 | 328 | -- | For each interface, generate the callback API. 329 | generateListenerMethods :: ProtocolSpec -> ServerClient -> ProcessWithExports [Dec] 330 | generateListenerMethods sp sc = do 331 | let pname = protocolName sp 332 | 333 | interfaces <- liftM concat $ sequence $ map (\iface -> generateListener sp iface sc) $ 334 | filter (\iface -> 0 < (length $ case sc of 335 | Server -> interfaceRequests iface 336 | Client -> interfaceEvents iface)) $ protocolInterfaces sp 337 | 338 | -- For a new_id type argument, server-side, we are passed raw new_id's. 339 | -- Since the only sensible thing to do is to create the requested object, 340 | -- these bindings to that for the user, saving code duplication. 341 | resourceCreators <- 342 | case sc of 343 | Client -> return [] -- resources are created Server-side, and Client's proxies are created by the wayland library always 344 | Server -> lift $ liftM concat $ sequence $ 345 | map (\ iface -> do 346 | let iname = interfaceName iface 347 | internalCName = mkName $ pname ++ "_" ++ iname ++ "_c_resource_create" 348 | foreignDec <- forImpD cCall unsafe "wl_resource_create" internalCName [t|Util.Client -> CInterface -> CInt -> {#type uint32_t#} -> IO $(conT $ mkName $ interfaceTypeName pname iname) |] 349 | neatDec <- [d|$(varP $ interfaceResourceCreator pname iname) = \ client id -> 350 | $(varE internalCName) client $(varE $ interfaceCInterfaceName pname iname) $(litE $ IntegerL $ fromIntegral $ interfaceVersion iface) id|] 351 | return $ foreignDec : neatDec 352 | ) (protocolInterfaces sp) 353 | return $ interfaces ++ resourceCreators 354 | 355 | 356 | -- | Generate a specific interface's callback API 357 | generateListener :: ProtocolSpec -> Interface -> ServerClient -> ProcessWithExports [Dec] 358 | generateListener sp iface sc = do 359 | -- Tree of possibilities: 360 | -- - Server 361 | -- => call it an Implementation or Interface. first argument is the client, second is the resource 362 | -- - Client 363 | -- => call it a Listener. first argument is the proxy 364 | -- 365 | -- for each argument (we're not gonna deal with untyped objects or new_ids): 366 | -- - typed new_id 367 | -- - Client 368 | -- => that type as arg 369 | -- - Server 370 | -- => uint32_t (the actual id. so that's new. dunno how to handle this. it's to be passed to wl_resource_create. maybe i should just create the resource for the server and pass that.) 371 | -- - anything else 372 | -- => the type you'd expect 373 | let -- declare a Listener or Interface type for this interface 374 | typeName :: Name 375 | typeName = messageListenerTypeName sc (protocolName sp) (interfaceName iface) 376 | pname = protocolName sp 377 | iname :: String 378 | iname = interfaceName iface 379 | messages :: [Message] 380 | messages = case sc of 381 | Server -> interfaceRequests iface 382 | Client -> interfaceEvents iface 383 | mkMessageName :: Message -> String 384 | mkMessageName msg = messageListenerMessageName sc pname iname (messageName msg) 385 | 386 | -- In the weird uint32_t new_id case, first pass the id through @wl_resource_create@ to just get a resource 387 | -- See resourceCreators in 'generateListenerMethods' above. 388 | preCompResourceCreate clientName msg fun = 389 | case sc of 390 | Client -> fun 391 | Server -> foldr (\(arg, idx) curFunc -> 392 | case arg of 393 | (_, NewIdArg _ itsName, _) -> 394 | preComposeAt 395 | curFunc 396 | [e|$(varE $ interfaceResourceCreator pname itsName) $(varE clientName) |] 397 | idx 398 | (length $ messageArguments msg) 399 | _ -> curFunc 400 | ) fun (zip (messageArguments msg) [1..]) 401 | 402 | -- instance dec: this struct better be Storable 403 | instanceDec :: DecsQ 404 | instanceDec = do 405 | [d|instance Storable $(conT typeName) where 406 | sizeOf _ = $(litE $ IntegerL $ funcSize * (fromIntegral $ length messages)) 407 | alignment _ = $(return $ LitE $ IntegerL funcAlign) 408 | peek _ = undefined -- we shouldn't need to be able to read listeners (since we can't change them anyway) 409 | poke ptr record = $(doE $ ( zipWith (\ idx msg -> 410 | noBindS [e|do 411 | let haskFun = $(varE $ mkName $ mkMessageName msg) record 412 | unmarshaller fun = \x -> $(let (pats, funexp) = argTypeUnmarshaller (messageArguments msg) ([e|fun x|]) 413 | in LamE pats <$> funexp) 414 | 415 | -- The C code wants to call back into Haskell, which we allow by passing 416 | -- our Haskell functions through @foreign import "wrapper"@. 417 | -- This allocates memory, which should be freed when the object is no longer used. 418 | funptr <- $(case sc of -- the Server-side listeners take an extra Client argument 419 | Server -> [e|$(varE $ wrapperName msg) $ \ client -> ($(preCompResourceCreate 'client msg [e|unmarshaller $ haskFun client|])) |] 420 | -- The Client-side listener takes a void* user_data argument, which we throw out. 421 | -- This API assumes that if users want to store data, they can do so using currying. 422 | Client -> [e|$(varE $ wrapperName msg) $ \ _ -> unmarshaller haskFun|]) 423 | 424 | pokeByteOff ptr $(litE $ IntegerL (idx * funcSize)) funptr 425 | |] ) 426 | [0..] messages 427 | ) ++ [noBindS [e|return () |]] ) 428 | |] 429 | 430 | 431 | -- FunPtr wrapper. Wraps a Haskell function into a function that can be called by C (ie. wayland). 432 | mkListenerCType msg = case sc of 433 | Server -> [t|Util.Client -> $(conT $ mkName $ interfaceTypeName pname iname) -> $(genMessageWeirdCType Nothing $ messageArguments msg)|] -- see large comment above 434 | Client -> [t|Ptr () -> $(conT $ mkName $ interfaceTypeName pname iname) -> $(genMessageCType Nothing $ messageArguments msg)|] 435 | wrapperName msg = messageListenerWrapperName sc iname (messageName msg) 436 | wrapperDec msg = forImpD cCall unsafe "wrapper" (wrapperName msg) [t|$(mkListenerCType msg) -> IO (FunPtr ($(mkListenerCType msg))) |] 437 | 438 | -- Bind add_listener. This instructs wayland to use our callbacks. 439 | haskName = requestHaskName pname iname "set_listener" -- dunno why I can't use this variable in the splice below. 440 | export haskName 441 | let 442 | foreignName = requestInternalCName iname "c_add_listener" 443 | foreignDec :: Q Dec 444 | foreignDec = case sc of 445 | -- From the wayland header files: 446 | -- void wl_resource_set_implementation(struct wl_resource *resource, 447 | -- const void *implementation, 448 | -- void *data, 449 | -- wl_resource_destroy_func_t destroy); 450 | -- typedef void (*wl_resource_destroy_func_t)(struct wl_resource *resource); 451 | Server -> 452 | forImpD 453 | cCall 454 | unsafe 455 | "wl_resource_set_implementation" 456 | foreignName 457 | [t| 458 | $(conT $ mkName $ interfaceTypeName pname iname) 459 | -> (Ptr $(conT $ typeName)) 460 | -> (Ptr ()) 461 | -> FunPtr ($(conT $ mkName $ interfaceTypeName pname iname) -> IO ()) 462 | -> IO () 463 | |] 464 | -- int wl_proxy_add_listener(struct wl_proxy *proxy, 465 | -- void (**implementation)(void), void *data); 466 | Client -> 467 | forImpD 468 | cCall 469 | unsafe 470 | "wl_proxy_add_listener" 471 | foreignName 472 | [t| 473 | $(conT $ mkName $ interfaceTypeName pname iname) 474 | -> (Ptr $(conT $ typeName)) 475 | -> (Ptr ()) 476 | -> IO CInt 477 | |] 478 | apiDec :: Q [Dec] 479 | apiDec = [d| 480 | $(varP $ mkName haskName) = 481 | \ iface listener -> 482 | do 483 | -- malloc RAM for Listener type. FIXME: free on object destruction. 484 | memory <- malloc 485 | -- store Listener type 486 | poke memory listener 487 | -- call foreign add_listener on stored Listener type 488 | $(case sc of 489 | Server -> [e|$(varE foreignName) iface memory nullPtr nullFunPtr|] 490 | Client -> [e|errToResult <$> $(varE foreignName) iface memory nullPtr|]) 491 | 492 | |] 493 | 494 | 495 | some <- lift $ sequence $ map wrapperDec messages 496 | 497 | other <- lift $ instanceDec 498 | more <- lift $ foreignDec 499 | last <- lift $ apiDec 500 | 501 | return $ some ++ other ++ [more] ++ last 502 | 503 | -- | Generate all data-types that should be exposed as Client-side API 504 | generateClientTypes :: ProtocolSpec -> Q [Dec] 505 | generateClientTypes ps = do 506 | dataTypes <- generateDataTypes ps 507 | listenerTypes <- generateListenerTypes ps Client 508 | enums <- generateEnums ps 509 | 510 | return $ dataTypes ++ listenerTypes ++ enums 511 | 512 | -- | Generate internal binding code (e.g. foreign imports) 513 | generateClientInternal :: ProtocolSpec -> Q [Dec] 514 | generateClientInternal ps = do 515 | (methods, _) <- runWriterT $ generateMethods ps Client 516 | (listeners, _) <- runWriterT $ generateListenerMethods ps Client 517 | (registry, _ ) <- runWriterT $ generateRegistryBind ps 518 | cInterfaces <- generateCInterfaceDecs ps 519 | 520 | return $ methods ++ listeners ++ registry ++ cInterfaces 521 | 522 | -- | Generate code that exports the right symbols to the user 523 | generateClientExports :: ProtocolSpec -> Q [Dec] 524 | generateClientExports ps = do 525 | (_, methodNames) <- runWriterT $ generateMethods ps Client 526 | (_, listenerNames) <- runWriterT $ generateListenerMethods ps Client 527 | (_, registryNames) <- runWriterT $ generateRegistryBind ps 528 | let names = methodNames ++ listenerNames ++ registryNames 529 | 530 | liftM concat $ mapM nameToDec names 531 | where 532 | nameToDec :: String -> Q [Dec] 533 | nameToDec name = [d|$(varP $ mkName name) = $(varE $ mkName $ "Import." ++ name) |] 534 | 535 | -- | Generate all data-types that should be exposed as Server-side API 536 | generateServerTypes :: ProtocolSpec -> Q [Dec] 537 | generateServerTypes ps = do 538 | dataTypes <- generateDataTypes ps 539 | listenerTypes <- generateListenerTypes ps Server 540 | enums <- generateEnums ps 541 | 542 | return $ dataTypes ++ listenerTypes ++ enums 543 | 544 | -- | Generate internal binding code (e.g. foreign imports) 545 | generateServerInternal :: ProtocolSpec -> Q [Dec] 546 | generateServerInternal ps = do 547 | (methods, _) <- runWriterT $ generateMethods ps Server 548 | (listeners, _) <- runWriterT $ generateListenerMethods ps Server 549 | cInterfaces <- generateCInterfaceDecs ps 550 | 551 | return $ methods ++ listeners ++ cInterfaces 552 | 553 | -- | Generate code that exports the right symbols to the user 554 | generateServerExports :: ProtocolSpec -> Q [Dec] 555 | generateServerExports ps = do 556 | --(_, enumNames) <- runWriterT $ generateEnums ps 557 | (_, methodNames) <- runWriterT $ generateMethods ps Server 558 | (_, listenerNames) <- runWriterT $ generateListenerMethods ps Server 559 | let names = methodNames ++ listenerNames 560 | 561 | liftM concat $ mapM nameToDec names 562 | where 563 | nameToDec :: String -> Q [Dec] 564 | nameToDec name = [d|$(varP $ mkName name) = $(varE $ mkName $ "Import." ++ name) |] 565 | 566 | -- 567 | -- Helper functions below 568 | -- 569 | 570 | genMessageCType :: Maybe TypeQ -> [Argument] -> TypeQ 571 | genMessageCType = genMessageType argTypeToCType 572 | 573 | genMessageWeirdCType :: Maybe TypeQ -> [Argument] -> TypeQ 574 | genMessageWeirdCType = genMessageType argTypeToWeirdInterfaceCType 575 | 576 | genMessageHaskType :: Maybe TypeQ -> [Argument] -> TypeQ 577 | genMessageHaskType = genMessageType argTypeToHaskType 578 | 579 | genMessageType :: (Argument -> TypeQ) -> Maybe TypeQ -> [Argument] -> TypeQ 580 | genMessageType fun Nothing args = 581 | foldr (\addtype curtype -> [t|$(fun addtype) -> $curtype|]) [t|IO ()|] args 582 | genMessageType fun (Just someType) args = 583 | foldr (\addtype curtype -> [t|$(fun addtype) -> $curtype|]) someType args 584 | 585 | -- | 3-tuple version of snd 586 | snd3 :: (a,b,c) -> b 587 | snd3 (_,b,_) = b 588 | 589 | -- | Check if a given message argument is of type new_id 590 | isNewId :: Argument -> Bool 591 | isNewId arg = case arg of 592 | (_, NewIdArg _ _, _) -> True 593 | _ -> False 594 | -------------------------------------------------------------------------------- /Graphics/Wayland/Scanner/Marshaller.chs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell, DeriveDataTypeable #-} 2 | module Graphics.Wayland.Scanner.Marshaller ( 3 | argTypeToCType, argTypeToHaskType, argTypeToWeirdInterfaceCType, 4 | 5 | argTypeMarshaller, argTypeUnmarshaller, 6 | 7 | funcSize, funcAlign 8 | ) where 9 | 10 | import Control.Exception.Base (bracket) 11 | import Data.Functor 12 | import Data.Fixed (Fixed(..)) 13 | import Foreign 14 | import Foreign.C.Types 15 | import Foreign.C.String 16 | import System.Process 17 | import System.IO 18 | import System.Posix.Types 19 | import Language.Haskell.TH 20 | 21 | import Graphics.Wayland.Internal.Util (Fixed256, Time, millisecondsToTime, timeToMilliseconds) 22 | import Graphics.Wayland.Scanner.Protocol 23 | import Graphics.Wayland.Scanner.Names 24 | import Graphics.Wayland.Scanner.Types 25 | 26 | #include 27 | 28 | {#context prefix="wl"#} 29 | 30 | 31 | wlFixedToFixed256 :: CInt -> Fixed256 32 | wlFixedToFixed256 = MkFixed . fromIntegral 33 | fixed256ToWlFixed :: Fixed256 -> CInt 34 | fixed256ToWlFixed (MkFixed a) = fromIntegral a 35 | 36 | -- {#pointer * array as WLArray nocode#} 37 | 38 | argTypeToCType :: Argument -> TypeQ 39 | argTypeToCType (_,IntArg,_) = [t| {#type int32_t#} |] 40 | argTypeToCType (_,UIntArg,_) = [t| {#type uint32_t#} |] 41 | argTypeToCType (_,FixedArg,_) = [t|{#type fixed_t#}|] 42 | argTypeToCType (_,StringArg,_) = [t| Ptr CChar |] 43 | argTypeToCType (_,(ObjectArg iname),_) = return $ ConT iname 44 | argTypeToCType (_,(NewIdArg iname _),_) = return $ ConT iname 45 | argTypeToCType (_,ArrayArg,_) = [t|WLArray|] 46 | argTypeToCType (_,FdArg,_) = [t| {#type int32_t#} |] 47 | 48 | argTypeToHaskType :: Argument -> TypeQ 49 | argTypeToHaskType (_,IntArg,_) = [t|Int|] 50 | argTypeToHaskType (name,UIntArg,_) 51 | | name == "time" = [t|Time|] 52 | | otherwise = [t|Word|] 53 | argTypeToHaskType (_,FixedArg,_) = [t|Fixed256|] 54 | argTypeToHaskType (_,StringArg,False) = [t|String|] 55 | argTypeToHaskType (_,(ObjectArg iname),False) = return $ ConT iname 56 | argTypeToHaskType (_,(NewIdArg iname _),False) = return $ ConT iname 57 | argTypeToHaskType (_,StringArg,True) = [t|Maybe String|] 58 | argTypeToHaskType (_,(ObjectArg iname),True) = [t|Maybe $(conT iname) |] 59 | argTypeToHaskType (_,(NewIdArg iname _),True) = [t|Maybe $(conT iname) |] 60 | argTypeToHaskType (_,ArrayArg,True) = [t|Maybe (Int, Ptr ())|] -- size_t size and void* 61 | argTypeToHaskType (_,ArrayArg,False) = [t|(Int, Ptr ())|] -- size_t size and void* 62 | argTypeToHaskType (_,FdArg,_) = [t|Fd|] 63 | 64 | argTypeToWeirdInterfaceCType :: Argument -> TypeQ 65 | argTypeToWeirdInterfaceCType (_,(NewIdArg iname _),_) = [t|{#type uint32_t#}|] 66 | argTypeToWeirdInterfaceCType x = argTypeToCType x 67 | 68 | marshallerVar :: Argument -> Name 69 | marshallerVar (name, _, _) = mkName name 70 | 71 | -- | Allows a C function to receive Haskell data 72 | argTypeMarshaller :: [Argument] -> ExpQ -> ([Pat], ExpQ) 73 | argTypeMarshaller args fun = 74 | let vars = map marshallerVar args 75 | mk = return . VarE . marshallerVar 76 | applyMarshaller :: [Argument] -> ExpQ -> ExpQ 77 | applyMarshaller (arg@(_, IntArg, _):as) fun = [|$(applyMarshaller as [|$fun (fromIntegral ($(mk arg) :: Int) )|])|] 78 | applyMarshaller (arg@(name, UIntArg, _):as) fun 79 | | name == "time" = [|$(applyMarshaller as [|$fun (timeToMilliseconds ($(mk arg) :: Time))|]) |] 80 | | otherwise = [|$(applyMarshaller as [|$fun (fromIntegral ($(mk arg) :: Word))|]) |] 81 | applyMarshaller (arg@(_, FixedArg, _):as) fun = [|$(applyMarshaller as [|$fun (fixed256ToWlFixed $(mk arg))|]) |] 82 | applyMarshaller (arg@(_, StringArg, False):as) fun = [|withCString $(mk arg) (\cstr -> $(applyMarshaller as [|$fun cstr|]))|] 83 | applyMarshaller (arg@(_, (ObjectArg iname), False):as) fun = [|$(applyMarshaller as [|$fun $(mk arg)|]) |] 84 | applyMarshaller (arg@(_, (NewIdArg iname _), False):as) fun = [|$(applyMarshaller as [|$fun $(mk arg) |])|] 85 | applyMarshaller (arg@(_, StringArg, True):as) fun = [| 86 | case $(mk arg) of 87 | Nothing -> $(applyMarshaller as [|$fun nullPtr|]) 88 | Just str -> withCString str (\cstr -> $(applyMarshaller as [|$fun cstr|])) 89 | |] 90 | applyMarshaller (arg@(_, (ObjectArg iname), True):as) fun = [| 91 | case $(mk arg) of 92 | Nothing -> $(applyMarshaller as [|$fun ($(conE iname) nullPtr)|]) 93 | Just obj -> $(applyMarshaller as [|$fun obj|]) 94 | |] 95 | applyMarshaller (arg@(_, (NewIdArg iname _), True):as) fun = [| 96 | case $(mk arg) of 97 | Nothing -> $(applyMarshaller as [|$fun ($(conE iname) nullPtr)|]) 98 | Just obj -> $(applyMarshaller as [|$fun obj|]) 99 | |] 100 | applyMarshaller (arg@(_, ArrayArg, True):as) fun = [| 101 | case $(mk arg) of 102 | Nothing -> $(applyMarshaller as [|$fun nullPtr|]) 103 | Just (size, dat) -> bracket 104 | (mallocBytes (2*{#sizeof size_t#}+ 4)) -- FIXME prettify / make portable. is this even right? 105 | (free) 106 | (\arrayPtr -> do 107 | {#set array.size#} arrayPtr size 108 | {#set array.alloc#} arrayPtr size -- FIXME or should we force powers of 2? 109 | {#set array.data#} arrayPtr dat 110 | $(applyMarshaller as [|$fun arrayPtr|]) 111 | ) 112 | |] 113 | applyMarshaller (arg@(_, ArrayArg, False):as) fun = [| 114 | do 115 | let (size, dat) = $(mk arg) 116 | bracket 117 | (mallocBytes (2*{#sizeof size_t#}+ 4)) -- FIXME prettify / make portable. is this even right? 118 | (free) 119 | (\arrayPtr -> do 120 | {#set array.size#} arrayPtr size 121 | {#set array.alloc#} arrayPtr size -- FIXME or should we force powers of 2? 122 | {#set array.data#} arrayPtr dat 123 | $(applyMarshaller as [|$fun arrayPtr|]) 124 | ) 125 | |] 126 | applyMarshaller (arg@(_, FdArg, _):as) fun = [|$(applyMarshaller as [|$fun (unFd ($(mk arg)))|]) |] 127 | applyMarshaller [] fun = fun 128 | in (map VarP vars, applyMarshaller args fun) 129 | 130 | unFd (Fd k) = k 131 | 132 | -- | Opposite of argTypeMarshaller: allows a Haskell function to receive C data. 133 | argTypeUnmarshaller :: [Argument] -> ExpQ -> ([Pat], ExpQ) 134 | argTypeUnmarshaller args fun = 135 | let vars = map marshallerVar args 136 | mk = return . VarE . marshallerVar 137 | applyUnmarshaller :: [Argument] -> ExpQ -> ExpQ 138 | applyUnmarshaller (arg@(_, IntArg, _):as) fun = [|$(applyUnmarshaller as [|$fun (fromIntegral ($(mk arg) :: CInt) )|])|] 139 | applyUnmarshaller (arg@(name, UIntArg, _):as) fun 140 | | name == "time" = [|$(applyUnmarshaller as [|$fun (millisecondsToTime ($(mk arg) :: CUInt))|]) |] 141 | | otherwise = [|$(applyUnmarshaller as [|$fun (fromIntegral ($(mk arg) :: CUInt))|]) |] 142 | applyUnmarshaller (arg@(_, FixedArg, _):as) fun = [|$(applyUnmarshaller as [|$fun (wlFixedToFixed256 $(mk arg))|]) |] 143 | applyUnmarshaller (arg@(_, StringArg, False):as) fun = [|do str <- peekCString $(mk arg); $(applyUnmarshaller as [|$fun str|])|] 144 | applyUnmarshaller (arg@(_, (ObjectArg iname), False):as) fun = [|$(applyUnmarshaller as [|$fun $(mk arg)|]) |] 145 | applyUnmarshaller (arg@(_, (NewIdArg iname _), False):as) fun = [|$(applyUnmarshaller as [|$fun $(mk arg) |])|] 146 | applyUnmarshaller (arg@(_, StringArg, True):as) fun = [|do 147 | str <- if $(mk arg) == nullPtr 148 | then return Nothing 149 | else Just <$> peekCString $(mk arg) 150 | $(applyUnmarshaller as [|$fun str|]) 151 | |] 152 | applyUnmarshaller (arg@(_, (ObjectArg iname), True):as) fun = [|$(applyUnmarshaller as [|$fun $ 153 | let $(conP iname ([varP $ mkName "ptr___"])) = $(mk arg) 154 | in if $(varE $ mkName "ptr___") == nullPtr 155 | then Nothing 156 | else Just $(mk arg)|]) |] 157 | applyUnmarshaller (arg@(_, (NewIdArg iname _), True):as) fun = [|$(applyUnmarshaller as [|$fun $ 158 | if $(mk arg) == nullPtr 159 | then Nothing 160 | else Just $ $(conE iname) $(mk arg)|]) |] 161 | applyUnmarshaller (arg@(_, ArrayArg, True):as) fun = [| 162 | if $(mk arg) == nullPtr 163 | then $(applyUnmarshaller as [|$fun Nothing|]) 164 | else do 165 | size <- fromIntegral <$> {#get array->size#} ($(mk arg) :: WLArray) 166 | dat <- {#get array->data#} ($(mk arg) :: WLArray) 167 | $(applyUnmarshaller as [|$fun (Just (size, dat)) |]) 168 | |] 169 | applyUnmarshaller (arg@(_, ArrayArg, False):as) fun = [|do 170 | size <- fromIntegral <$> {#get array->size#} ($(mk arg) :: WLArray) 171 | dat <- {#get array->data#} ($(mk arg) :: WLArray) 172 | $(applyUnmarshaller as [|$fun (size, dat) |]) 173 | |] 174 | applyUnmarshaller (arg@(_, FdArg, _):as) fun = [|$(applyUnmarshaller as [|$fun (Fd ($(mk arg)))|]) |] 175 | applyUnmarshaller [] fun = fun 176 | in (map VarP vars, applyUnmarshaller args fun) 177 | 178 | 179 | -- compute FunPtr size and alignment based on some dummy C type 180 | funcSize = {#sizeof notify_func_t#} :: Integer 181 | funcAlign = {#alignof notify_func_t#} :: Integer 182 | -------------------------------------------------------------------------------- /Graphics/Wayland/Scanner/Names.hs: -------------------------------------------------------------------------------- 1 | module Graphics.Wayland.Scanner.Names ( 2 | ServerClient(..), 3 | 4 | registryBindName, 5 | -- apparently we are not allowed to use foreign C names generated by the C scanner 6 | requestInternalCName, eventInternalCName, 7 | -- requestForeignCName, eventForeignCName, 8 | requestHaskName, eventHaskName, 9 | 10 | interfaceTypeName, interfaceCInterfaceName, 11 | enumTypeName, enumEntryHaskName, 12 | messageListenerTypeName, 13 | messageListenerMessageName, 14 | messageListenerWrapperName, 15 | interfaceResourceCreator, 16 | 17 | capitalize 18 | ) where 19 | 20 | import Data.Char 21 | import Data.List 22 | import Language.Haskell.TH 23 | 24 | import Graphics.Wayland.Scanner.Types 25 | 26 | 27 | registryBindName :: ProtocolName -> InterfaceName -> String 28 | registryBindName pname iname = "registryBind" ++ (capitalize $ haskifyInterfaceName pname iname) 29 | 30 | requestInternalCName :: InterfaceName -> MessageName -> Name 31 | requestInternalCName iface msg = mkName $ iface ++ "_" ++ msg ++ "_request_binding" 32 | eventInternalCName :: InterfaceName -> MessageName -> Name 33 | eventInternalCName iface msg = mkName $ iface ++ "_" ++ msg ++ "_event_binding" 34 | 35 | requestHaskName :: ProtocolName -> InterfaceName -> MessageName -> String 36 | requestHaskName pname iname mname = toCamel (haskifyInterfaceName pname iname ++ "_" ++ mname) 37 | eventHaskName :: ProtocolName -> InterfaceName -> MessageName -> String 38 | eventHaskName = requestHaskName 39 | enumEntryHaskName :: ProtocolName -> InterfaceName -> EnumName -> String -> Name 40 | enumEntryHaskName pname iname ename entryName = 41 | mkName $ haskifyInterfaceName pname iname ++ capitalize (toCamel ename) ++ capitalize (toCamel entryName) 42 | 43 | interfaceTypeName :: ProtocolName -> InterfaceName -> String 44 | interfaceTypeName pname iname = capitalize $ haskifyInterfaceName pname iname 45 | 46 | interfaceCInterfaceName :: ProtocolName -> InterfaceName -> Name 47 | interfaceCInterfaceName _ iname = mkName $ iname ++ "_c_interface" 48 | 49 | enumTypeName :: ProtocolName -> InterfaceName -> EnumName -> Name 50 | enumTypeName pname iname ename = mkName $ capitalize $ haskifyInterfaceName pname iname ++ capitalize (toCamel ename) 51 | 52 | messageListenerTypeName :: ServerClient -> ProtocolName -> InterfaceName -> Name 53 | messageListenerTypeName Server pname iname = mkName $ capitalize (haskifyInterfaceName pname iname) ++ "Implementation" 54 | messageListenerTypeName Client pname iname = mkName $ capitalize (haskifyInterfaceName pname iname) ++ "Listener" 55 | 56 | messageListenerMessageName :: ServerClient -> ProtocolName -> InterfaceName -> MessageName -> String 57 | messageListenerMessageName Server = requestHaskName 58 | messageListenerMessageName Client = eventHaskName 59 | 60 | messageListenerWrapperName :: ServerClient -> InterfaceName -> MessageName -> Name 61 | messageListenerWrapperName Client iname mname = mkName $ iname ++ "_" ++ mname ++ "_listener_wrapper" 62 | messageListenerWrapperName Server iname mname = mkName $ iname ++ "_" ++ mname ++ "_implementation_wrapper" 63 | 64 | interfaceResourceCreator :: ProtocolName -> InterfaceName -> Name 65 | interfaceResourceCreator pname iname = mkName $ pname ++ "_" ++ iname ++ "_resource_create" 66 | 67 | -- | Some interfaces use a naming convention where wl_ or their protocol's name is prepended. 68 | -- We remove both because it doesn't look very Haskelly. 69 | haskifyInterfaceName :: ProtocolName -> InterfaceName -> String 70 | haskifyInterfaceName pname iname = 71 | toCamel $ removeInitial (pname ++ "_") $ removeInitial "wl_" iname 72 | 73 | 74 | -- stupid utility functions follow 75 | 76 | -- | if the second argument starts with the first argument, strip that start 77 | removeInitial :: Eq a => [a] -> [a] -> [a] 78 | removeInitial remove input = if remove `isPrefixOf` input 79 | then drop (length remove) input 80 | else input 81 | 82 | -- | convert some_string to someString 83 | toCamel :: String -> String 84 | toCamel (a:'_':c:d) | isAlpha a, isAlpha c = a : toUpper c : toCamel d 85 | toCamel (a:b) = a : toCamel b 86 | toCamel x = x 87 | 88 | 89 | capitalize :: String -> String 90 | capitalize x = toUpper (head x) : tail x 91 | 92 | -- decapitalize :: String -> String 93 | -- decapitalize x = toLower (head x) : tail x 94 | -------------------------------------------------------------------------------- /Graphics/Wayland/Scanner/Protocol.hs: -------------------------------------------------------------------------------- 1 | module Graphics.Wayland.Scanner.Protocol ( 2 | readProtocol, parseFile 3 | ) where 4 | 5 | import Data.Functor 6 | import Data.Maybe 7 | import Data.Char 8 | import Text.XML.Light 9 | import System.Process 10 | import Language.Haskell.TH (mkName) 11 | 12 | import Graphics.Wayland.Scanner.Types 13 | import Graphics.Wayland.Scanner.Names 14 | 15 | interface = QName "interface" Nothing Nothing 16 | request = QName "request" Nothing Nothing 17 | event = QName "event" Nothing Nothing 18 | enum = QName "enum" Nothing Nothing 19 | entry = QName "entry" Nothing Nothing 20 | arg = QName "arg" Nothing Nothing 21 | namexml = QName "name" Nothing Nothing 22 | version = QName "version" Nothing Nothing 23 | allow_null = QName "allow-null" Nothing Nothing 24 | typexml = QName "type" Nothing Nothing 25 | value = QName "value" Nothing Nothing 26 | 27 | parseInterface :: ProtocolName -> Element -> Interface 28 | parseInterface pname elt = 29 | let iname = fromJust $ findAttr namexml elt 30 | 31 | parseMessage :: Element -> Maybe Message 32 | parseMessage msgelt = do -- we're gonna do some fancy construction to skip messages we can't deal with yet 33 | let name = fromJust $ findAttr namexml msgelt 34 | arguments <- mapM parseArgument (findChildren arg msgelt) 35 | let destructorVal = findAttr typexml msgelt 36 | let isDestructor = case destructorVal of 37 | Nothing -> False 38 | Just str -> str=="destructor" 39 | 40 | return Message {messageName = name, messageArguments = arguments, messageIsDestructor = isDestructor} where 41 | parseArgument argelt = do 42 | let msgname = fromJust $ findAttr namexml argelt 43 | let argtypecode = fromJust $ findAttr typexml argelt 44 | argtype <- case argtypecode of 45 | "object" -> ObjectArg . mkName . interfaceTypeName pname <$> findAttr interface argelt 46 | "new_id" -> (\iname -> NewIdArg (mkName $ interfaceTypeName pname iname) iname) <$> findAttr interface argelt 47 | _ -> lookup argtypecode argConversionTable 48 | let allowNull = fromMaybe False (read <$> capitalize <$> findAttr allow_null argelt) 49 | return (msgname, argtype, allowNull) 50 | 51 | parseEnum enumelt = 52 | let enumname = fromJust $ findAttr namexml enumelt 53 | entries = map parseEntry $ findChildren entry enumelt 54 | in WLEnum {enumName = enumname, enumEntries = entries} where 55 | parseEntry entryelt = (fromJust $ findAttr namexml entryelt, 56 | read $ fromJust $ findAttr value entryelt :: Int) 57 | in Interface { 58 | interfaceName = iname, 59 | interfaceVersion = read $ fromJust $ findAttr version elt, -- unused atm 60 | interfaceRequests = mapMaybe parseMessage (findChildren request elt), 61 | interfaceEvents = mapMaybe parseMessage (findChildren event elt), 62 | interfaceEnums = map parseEnum $ findChildren enum elt 63 | } 64 | 65 | parseProtocol :: [Content] -> ProtocolSpec 66 | parseProtocol xmlTree = 67 | let subTree = (!!1) $ onlyElems xmlTree -- cut off XML header stuff 68 | pname = fromJust $ findAttr namexml subTree 69 | interfaces = map (parseInterface pname) $ findChildren interface subTree 70 | in ProtocolSpec pname interfaces 71 | 72 | parseFile :: FilePath -> IO ProtocolSpec 73 | parseFile filename = do 74 | fileContents <- readFile filename 75 | return $ parseProtocol $ parseXML fileContents 76 | 77 | -- | locate wayland.xml on disk and parse it 78 | readProtocol :: IO ProtocolSpec 79 | readProtocol = do 80 | datadir <- figureOutWaylandDataDir 81 | parseFile (datadir ++ "/" ++ protocolFile) 82 | 83 | 84 | -- TODO move this into some pretty Setup.hs thing as soon as someone complains about portability 85 | figureOutWaylandDataDir :: IO String 86 | figureOutWaylandDataDir = 87 | head <$> lines <$> readProcess "pkg-config" ["wayland-server", "--variable=pkgdatadir"] [] 88 | 89 | protocolFile = "wayland.xml" 90 | -------------------------------------------------------------------------------- /Graphics/Wayland/Scanner/Types.chs: -------------------------------------------------------------------------------- 1 | module Graphics.Wayland.Scanner.Types where 2 | 3 | import Foreign 4 | import Language.Haskell.TH (Name) 5 | 6 | #include 7 | 8 | {#context prefix="wl"#} 9 | 10 | data ServerClient = Server | Client deriving (Eq) 11 | 12 | -- | wayland-style interface name (e.g. wl_display) 13 | type InterfaceName = String 14 | data Interface = Interface { 15 | interfaceName :: InterfaceName, 16 | interfaceVersion :: Int, 17 | interfaceRequests :: [Message], -- ^ aka requests 18 | interfaceEvents :: [Message], 19 | interfaceEnums :: [WLEnum] 20 | } deriving (Show) 21 | 22 | type EnumName = String 23 | -- | wayland style enum specification (not Prelude) 24 | data WLEnum = WLEnum { 25 | enumName :: EnumName, 26 | enumEntries :: [(String,Int)] 27 | } deriving (Show) 28 | 29 | -- | wayland wire protocol argument type. we can't deal with untyped object/new-id arguments. 30 | data ArgumentType = IntArg | UIntArg | FixedArg | StringArg | ObjectArg Name | NewIdArg Name MessageName | ArrayArg | FdArg deriving (Show) 31 | argConversionTable :: [(String, ArgumentType)] -- for all easy argument types 32 | argConversionTable = [ 33 | ("int", IntArg), 34 | ("uint", UIntArg), 35 | ("fixed", FixedArg), 36 | ("string", StringArg), 37 | ("fd", FdArg), 38 | ("array", ArrayArg)] 39 | 40 | type Argument = (String, ArgumentType, Bool) -- name, argument type, allow-null 41 | 42 | type MessageName = String 43 | data Message = Message { 44 | messageName :: MessageName, 45 | messageArguments :: [Argument], 46 | messageIsDestructor :: Bool 47 | } deriving (Show) 48 | 49 | type ProtocolName = String 50 | data ProtocolSpec = ProtocolSpec { 51 | protocolName :: ProtocolName, 52 | protocolInterfaces :: [Interface] 53 | } deriving (Show) 54 | 55 | {#pointer * array as WLArray#} 56 | -------------------------------------------------------------------------------- /Graphics/Wayland/Server.hs: -------------------------------------------------------------------------------- 1 | module Graphics.Wayland.Server ( 2 | -- Expose built-in wayland functions 3 | module Graphics.Wayland.Internal.Server, 4 | Client(..), 5 | -- Expose scanned protocol 6 | module Graphics.Wayland.Internal.SpliceServer, 7 | module Graphics.Wayland.Internal.SpliceServerTypes, 8 | ) where 9 | 10 | import Graphics.Wayland.Internal.Server 11 | import Graphics.Wayland.Internal.SpliceServer 12 | import Graphics.Wayland.Internal.SpliceServerTypes 13 | import Graphics.Wayland.Internal.Util (Client(..)) 14 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2014 Auke Booij 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be included 12 | in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 17 | IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY 18 | CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, 19 | TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE 20 | SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /NOTES.md: -------------------------------------------------------------------------------- 1 | Overview 2 | === 3 | Wayland is a library with some helper programs. The library is linked to by both the client (which typically e.g. wants to draw a window) and the server (aka compositor). In essence, it is an event exchange mechanism. 4 | Additionally, wayland can help creating shared memory buffers to exchange bulk data (ie. screen drawings). 5 | 6 | All events (they are actually called "messages" in wayland, so we'll stick to that terminology) are sent by either the server to the client (this is what wayland calls an "event"), or by the client to the server (a "request" type message). 7 | A message is always bound to a wayland "object", which is an opaque wayland concept - for all uses and purposes, you can view it as an ID which you are free to associate to whatever objects your client/server works with. That means that the wayland protocol can be described as an object-oriented event passing library (although that's not entirely accurate, and probably not very helpful either). 8 | 9 | Other documentation: 10 | 11 | - [Official wayland docs](http://wayland.freedesktop.org/docs/html/) 12 | - [Pekka Paalanen's object lifespan blog post](http://ppaalanen.blogspot.com/2014/07/wayland-protocol-design-object-lifespan.html) 13 | - [Jason Ekstrand's wayland language bindings guide](http://www.jlekstrand.net/jason/projects/wayland/language-bindings-guide/) 14 | 15 | Terminology 16 | === 17 | - Event: something that's sent from the server to the client 18 | - Request: something that's sent from the client to the server 19 | - Message: either an event or a request. Always associated to an object (so either a proxy or a resource) 20 | - Object: either a wl\_object (no longer used except internally - we won't discuss it further but you may encounter it), or a wl\_proxy (client-side) or a wl\_resource (server-side) - there is a correspondence between wl\_proxy and wl\_resource, for they are both handles to the wayland objects that we don't otherwise have access to. All objects have a type, namely an interface. 21 | - Interface: either the protocol specification of an object (for example, there are the interfaces wl\_display, wl\_surface, wl\_keyboard, wl\_seat) (see the XML files) or a callback receiving mechanism on the server side (but luckily, in conversation, this name is not used to refer to those callbacks - they are called implementations) 22 | - Protocol: wayland's API consists of a relatively small set of semi-fixed utility functions (wayland-client.h, wayland-server.h, wayland-util.h, wayland-egl.h, wayland-version.h), and a list of interfaces that one can interact with, specified by XML files. E.g., wayland would define a "wl\_pointer" interface with a "motion" event with a "time" argument, and "surface\_x" and "surface\_y" coordinate arguments. 23 | - Proxy: the client-side representation of a wayland object 24 | - Resource: the server-side representation of a wayland object, but also used to refer to the object that both sides have handles to (ie. as a synonym for "wayland object") 25 | - Implementation: the server-side callback mechanism for receiving messages. In particular, a specific instance of callback specifications. 26 | - Enum: a list of constants. Used to give semantics to integer message arguments. Sometimes actually an enumeration, sometimes a bitfield, sometimes neither. 27 | - Argument: messages can have several bits of data associated with them, which are called arguments. 28 | - Listener: either a client-side callback mechanism, or a server-side wl\_listener (which is "primarily" used to receive a signal that objects are destroyed - apparently functionality that you don't really need) 29 | - List: a wl\_list or a wl\_array 30 | - Event queue: primarily used internally; can't be arsed to understand these. apparently some kind of client-side per-object store of messages that are pending processing 31 | - Event loop: either the code you write for a client that loops to process events (using wayland\_display\_dispatch), or a wl\_event\_loop on the server side, which implements the event loop for you (although this loop actually processes _requests_ rather than events, since the incoming messages into the server are _request_ type messages! but "request loop" would be a rather unhelpful name.) 32 | - Display: any of the following: the actual physical display, or a wl\_display, which has three strictly distinct flavors: a server side resource, a client side proxy, or a client side C struct which has a display proxy as its first member and is therefore usable as a proxy (the third option being the one that is returned by wl\_display\_connect) 33 | - Scanner: A piece of code that generates an API (wayland-server-protocol.h, wayland-client-protocol.h) from the protocol files (wayland.xml). These haskell bindings contain a scanner to generate a haskell API that binds to the C api generated by the wayland scanner. 34 | - Callback: either a normal callback into your code (as used in the receiving of messages on either end) or a wl\_callback, which I haven't figured out yet. 35 | - ... 36 | 37 | From here on, "object" refers to a wayland object in the sense of wl\_proxy or wl\_resource. 38 | 39 | Object creation 40 | === 41 | To send or receive messages, you have to first construct (on the server side) or request (on the client side) the object for which you want to send or receive messages, since all messages are associated to an object (additionally, on the server side, every object is associated to a client). 42 | But on the client side, the way you request objects is by sending the right request messages. 43 | So that leaves us with a dependency problem: as a client, how do you request your first object? 44 | This is what the Display (wl\_display) object is for: it is an singleton object which you get when you connect to a server (and whereas programs can connect as clients to several servers, yielding several wl\_display objects, creating several servers in the same program is a bit more subtle, and I don't want to get into that). 45 | 46 | Once you have a wl\_display, you can proceed to request the wl\_registry, which has a "bind" request that can construct all objects which are blessed to be "global" by the "global" event. 47 | The arguments to bind define the type of the return value, which is why we bind to it manually. 48 | Additionally, it is only known at runtime which objects can be constructed using bind (because they are advertised as such by the "global" event). 49 | 50 | The reason behind this is: 51 | 52 | 1. Different compositors implement different protocols, so having a connection does not guarantee that you can create the objects you want; 53 | 2. Some objects are associated to others (e.g. surfaces are associated to compositors), and as such may not be created without specifying their associated parent. 54 | 55 | So the purpose of a "global" event is twofold: the server tells you that it can create such an object, and in addition, that it doesn't require any further arguments (e.g. a parent object). 56 | 57 | In these bindings, we assume that if there is a way to request an object from another one, then you cannot use wl\_registry.bind, and that if you want to use wl\_registry.bind, you should first wait for the right globals to be available. 58 | 59 | wl\_display and wl\_registry are the only two protocol interfaces that have a sort of elevated status above the other interfaces: wl\_display is created via a process called "connecting to a server", and a wl\_registry is a sort of superinterface to create all kinds of other objects. 60 | 61 | I haven't yet figured out what the server side does here exactly. 62 | You can create objects using wl\_resource\_create, but to request objects internally, I think you just call your own code (which makes sense), rather than going via wayland. 63 | Additionally, presumably to do a wl\_resource\_create, you will need some kind of wl\_proxy to bind it to. 64 | IOW I *THINK* that servers are not free to construct wl\_resource instances as they please. 65 | 66 | As long as the client follows the protocol (ie. only construct objects which the server allowed it to construct), object creation is guaranteed to work. 67 | 68 | Object destruction 69 | === 70 | The client and server can both destroy objects: the client using wl\_proxy\_destroy, and the server using wl\_resource\_destroy. 71 | Additionally, some interfaces expose a "destroy" request, which, if available, must be used. 72 | 73 | HOWEVER, servers are not free to destroy whatever they please, for there is no standard way to inform the client that objects no longer exist. 74 | Hence, utmost care should be taken when you wish to destroy an object from the server side. 75 | Consider refactoring your protocol. 76 | 77 | Receiving messages 78 | === 79 | Messages are received on both sides using callbacks. 80 | On the client side, these are called when you call wayland\_display\_dispatch: so wayland continuously receives messages in the background, but only passes them to your callbacks when you ask it to. 81 | You specify these callbacks using the Listener stuff. 82 | Note that you can only set listeners once for every proxy! 83 | 84 | On the server side, there's a corresponding "interface" api, but the interfaces are also called "implementations" (as in: you specify the callbacks by setting the interface aka implementation), to differentiate from the client-side usage of the word "interface" (as in: a protocol consists of several interfaces). 85 | To dispatch your callbacks (ie actually process incoming requests), you call wl\_display\_run, or do some magic with wl\_event\_loops which I haven't figured out yet. 86 | 87 | Sending messages 88 | === 89 | Every message has a list of arguments. Every argument has a name and a type. The following types are available: 90 | 91 | - int, uint, fixed (integer, unsigned integer, float) 92 | - object, new\_id 93 | - array (which we don't bind to atm) 94 | - fd (just an integer) 95 | 96 | Most types speak for themselves, but the "object" and "new\_id" types need some discussion. 97 | 98 | Most arguments are sent in the direction of the message itself. However, the new\_id type is used to create or request objects: so a client can get access to an object by sending a request message which has a new_id type argument. 99 | 100 | Now, note that all objects "exist" at the server side - the wayland protocol simply provides an interface to them for the client. You can get and set its attributes using the various requests and events. 101 | 102 | When a new\_id argument is present, the request instructs the server to create an object with a given identification. 103 | Such creations are guaranteed to work as long as protocol is followed. 104 | So this gives the client a handle to an object on the server. 105 | Hence, in some sense, this argument flows in the other direction, but only in a semantic way: technically the client just sends a command to create an object to the server, and assumes it worked, but it kind of looks like the client "gets" an object from the server. 106 | 107 | These bindings can bind messages with a new\_id argument only if they are typed (ie. the type of the returned object is known at compile time). 108 | The only known exception is wl\_registry.bind, which has a special purpose anyway, and we'll bind manually. 109 | 110 | Various quotes from #wayland IRC 111 | === 112 | 113 | Requests are from the client to the server. Events are from the server to the client. 114 | 115 | 116 | there are all kinds of magic interfaces with special status, and stuff that you could have made symmetric between server and client, but didn't 117 | the magic interfaces are just wl_display and wl_registry 118 | that's it 119 | 120 | 121 | am i right in saying that the only signal emitted by wayland code is the destroy signal, which it emits when any wl_resource is destroyed? 122 | tulcod: I think so 123 | tulcod: wl_listener is for putting in a wl_signal (which we use for lots of stuff inside weston) whereas the interface has a bunch of different callbacks with different signatures each for a different event (client-side) or request (server-side) 124 | does that mean that except for the "destroy" stuff, the entire wl_signal and wl_listener API is a convenience for the user, and nohting to do with wayland? 125 | whereas interfaces (aka implementations?) are just the server-side way to receive events from a client? 126 | ie the wl_signal and wl_listener stuff is intended to exchange events /within the server/, instead of between the server and client? 127 | pretty much 128 | libwayland may use signals internally for some things too (I don't remember) 129 | but you can implement a wayland server without ever using one. 130 | 131 | 132 | so if i want to bind to wayland, do i bind to wl_listener at all? 133 | would a minimal API include it? 134 | tulcod: No, it's not needed. 135 | You may find it useful, but you can get along without it just fine. 136 | It's a convenience to know when a resource is destroyed. 137 | If you are wrapping the library, you know when a resource is destroyed, because somebody called the destroy function. 138 | 139 | 140 | "As all requests and events are always part of some interface (like a member of a class), this creates an interface hierarchy. For example, wl_compositor objects are created from wl_registry, and wl_surface objects are created from wl_compositor." 141 | so what if i use wl_registry.bind to create a wl_surface? 142 | tulcod: i'm not sure what will happen exactly but it won't work, as there is no wl_surface global. probably you'll get a protocol error 143 | oh, non sequitur, by the way 144 | giucam: but "Object creation never fails." 145 | tulcod: i don't think that applies to globals 146 | binding a global can fail, and the server will create a dummy wl_resource, send an error and destroy it 147 | ah, so it can fail, it's just that it tells you afterwards 148 | ie it tells you if it failed, or doesn't tell you anything if it succeeded 149 | but i'm not sure what wl_registry.bind returns if it fails 150 | i.e if it is a valid proxy, and what happens if you call a request on it 151 | probably fails in a non-destructive way 152 | 153 | 154 | tulcod, all requests always "succeed" - if they don't, you violated the protocol. 155 | 156 | 157 | tulcod, did you already notice that there are at least three different wl_display structs? 158 | server-side wl_display (opaque), client-side wl_display (opaque), and the wl_proxy cast to wl_display IIRC 159 | the first member of client wl_display is a wl_proxy 160 | so it's interchangeable 161 | 162 | 163 | tulcod, btw. another thing you should be wary with is wl_buffer. 164 | tulcod, again, the client-side wl_buffer is a wl_proxy. The server-side is the tricky one. 165 | pq: ah, but the server-side one is deprecated :) 166 | 167 | 168 | I wonder if wl_resource_destroy_func_t is needed for set_implementation calls which interface already contains destroy function 169 | yes, they serve different purposes 170 | The one on the interface lets you know that the client has sent the destroy request 171 | The wl_resource_destroy_func_t lets you know that the object has been destroyed and lets you clean stuff up. This happens to all the resources when the client disconnects. 172 | Cloudef: you mean "interfaces which have a 'destroy' request" ? 173 | tulcod: yes 174 | ok yes, then i agree with jekstrand 175 | jekstrand: on which function I should actually free the resource? 176 | weston seems to do this on the interface one 177 | (and on the other one too) 178 | (fwiw, it's no problem to free twice) 179 | Cloudef: You need to call wl_resource_destroy in the interface one. wl_resource_destroy calls th wl_resource_destroy_func_t one. 180 | Cloudef: If you're familiar with C++, wl_resource_destroy is like "delete res" whereas the wl_resource_destroy_func_t is like MyThing::~MyThing() 181 | why those two are separate is because wl_resource_destroy may end up called also at other times, namely when cleaning up state after a client disconnection. 182 | the interface one is just a request, that's all. there's no implicit destruction of resources. 183 | ..except on the client side, so the server side cannot really not do it, too 184 | since server and client must agree on what objects exist 185 | yup 186 | 187 | 188 | when we say that an object is a singleton, we usually mean the real object, not the protocol object 189 | 190 | 191 | jekstrand: uhm, so let's suppose the client has a wl_shell_surface 192 | jekstrand: and the server, for whatever reason, destroys it 193 | what am i missing? can't the client keep the handle to that non-existent object? 194 | the server can't just up and destroy it 195 | that's a broken server. Clients shouldn't handle that case. 196 | jekstrand: okay, so compositors can't freely destroy stuff? 197 | nope 198 | If compositors were allowed to add-hock destroy client's objects, that would result in insanity 199 | 200 | 201 | RE: Object destruction: A better way to think about the object lifecycle is that the client manages (creates/destroys) objects. The special cases of server-destroyed objects isn't so much the server destroying things as objects getting "automatically" destroyed because it's clear that they're no longer needed (such as when a wl_callback is finished.) The server simply storres them. 202 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | ## Notice (2015-12-06) ## 2 | I am not happy with these bindings and have started writing a [new](https://github.com/tulcod/sudbury) Haskell wayland interface. It is far from usable. If you want to start a project based on these bindings: I would advise you to wait for that new project to be at a further stage instead. 3 | 4 | # Haskell Wayland bindings # 5 | Uh... these are what you'd expect. 6 | 7 | > NOTE: obviously this thing is incomplete, and needs more documentation and stuff. I'm very happy to work on that, but please let me know what **you** think requires attention. 8 | 9 | Refer to `NOTES.md` for more notes on wayland terminology, how it works, and ways to shoot yourself in the foot. 10 | 11 | 12 | ## Quick example ## 13 | 14 | > This paragraph is literate haskell. 15 | 16 | In this example (available as the `wayland-list-globals` executable), we are going to list the objects that the server allows us to construct directly (ie. without a relevant parent object). 17 | 18 | Let's start with some imports. We'll need to poll for a connection, so import Fd waiting tools. 19 | 20 | > import Control.Concurrent (threadWaitRead) 21 | 22 | We are going to write a Client-side program, so: 23 | 24 | > import Graphics.Wayland.Client 25 | 26 | > main = do 27 | 28 | Let's connect to the display server (e.g.) weston. displayConnect takes no arguments and tries to connect to a server based on environment variables. 29 | 30 | > connect <- displayConnect 31 | > let display = case connect of 32 | > Just x -> x 33 | > Nothing -> error "couldn't connect to a wayland server" 34 | 35 | We'll need to poll for the status of the socket connection between this client and the server, so let's go ahead and store the file descriptor. 36 | 37 | > fd <- displayGetFd display 38 | > putStrLn $ "Using file descriptor " ++ show fd 39 | > putStrLn $ "Display at " ++ show display 40 | 41 | The "registry" is the entry point to get access to the server's useful objects. 42 | 43 | > registry <- displayGetRegistry display 44 | > putStrLn $ "Registry at "++ show registry 45 | 46 | You can't just arbitrarily create objects via wayland: the registry has to let you know that a certain "global" has become available for construction. 47 | It does so by sending an "event" (ie. a message from the server to the client) that it has. 48 | So let's go ahead and write code that can listen to such events. 49 | The registry offers two events: 50 | - a "global" event indicating that an object has become available for construction, and 51 | - a "global_remove" event indicating that an object is no longer constructible. 52 | 53 | > let listener = RegistryListener { 54 | > registryGlobal = \reg name ifacename version -> putStrLn $ "Received global " ++ show name ++ " (" ++ ifacename ++ ") version " ++ show version, 55 | > registryGlobalRemove = \ _ _ -> return () 56 | > } 57 | 58 | Now we need to activate this listener. 59 | Client-side, you can only set a specific object's listener once, so this operation might fail if you already set one previously. 60 | 61 | > errorCode <- registrySetListener registry listener 62 | > putStrLn $ "Setting registry listener... " ++ show errorCode 63 | 64 | We are now ready to start receiving the "global" events. 65 | Before reading, we need to let wayland know we want to read - essentially meaning we lock (in the sense of mutex) the reading mechanism. 66 | 67 | > res <- displayPrepareRead display 68 | > putStrLn $ "Preparing read... " ++ show res 69 | 70 | As long as you stick to the protocol rules (which, as far as I'm away, aren't formally laid down anywhere), wayland object construction is free from failure. 71 | This allows the client to not have to wait for the server to do its part - it can just pretend everything worked and steam ahead. 72 | But that means that the construction of the registry we did earlier might actually not have reached the server yet. 73 | So before we do anything else, we should flush the write buffer. 74 | 75 | > flushed <- displayFlush display 76 | > putStrLn $ "Flushed " ++ show flushed 77 | 78 | Now poll for the socket to have data available. 79 | 80 | > putStrLn "polling" 81 | > threadWaitRead fd 82 | > putStrLn $ "Ready to read." 83 | 84 | We can now process the data that's waiting for us on the socket, and dispatch the event listeners. 85 | The latter will call e.g. our registryGlobal function with the incoming event's parameters. 86 | 87 | > events <- displayReadEvents display 88 | > putStrLn $ "Read display events: " ++ show events 89 | > dispatched <- displayDispatchPending display 90 | > putStrLn $ "Dispatched events: " ++ show dispatched 91 | 92 | All wayland objects we constructed are automatically destroyed when we disconnect. 93 | 94 | > displayDisconnect display 95 | 96 | 97 | ## API design and symbol naming ## 98 | 99 | The majority of the Wayland API is based on an object-oriented event framework. 100 | The objects have a type, which wayland calls an _interface_. 101 | A _protocol_ defines a list of such interfaces. 102 | 103 | Haskell renames these interfaces by, if possible, removing `wl_`, and, if possible, removing `_`, and then converting to CamelCase. 104 | For example: 105 | 106 | - `wl_display` is called `Display` in haskell-wayland 107 | - `wl_registry` -> `Registry` 108 | - `xdg_shell` -> `XdgShell` (as of this writing, however, `xdg_shell` is not in the default wayland protocol - but you can access it by generating the haskell-wayland API using the corresponding protocol XML files) 109 | - `wl_text_input` (in the `text.xml` protocol) -> `Input` (which for semantic reasons should be placed in a Haskell module whose name makes it clear that it corresponds to text input) 110 | - ... 111 | 112 | Wayland names the actions on these interfaces e.g. `wl_display_connect` or `wl_compositor_create_region`. haskell-wayland converts these names into camelCase, so that you would call `displayConnect` or `compositorCreateRegion`. 113 | 114 | 115 | ## Splicing a different protocol XML file ## 116 | 117 | Wayland has a "core" API (specified by `wayland-{client,server,util,egl,cursor}.h`, bound in `Graphics.Wayland.Internal.{Client,Server,...}`), and on top of that generates two header files (`wayland-{client,server}-protocol.h`) from an XML file detailing the wayland wire protocol. 118 | A wayland compositor might support several such protocols (e.g. as of this writing, weston supports the core `wayland.xml` protocol, as well as `desktop-shell.xml`, `fullscreen-shell.xml`, `input-method.xml`, `screenshooter.xml`, ...). 119 | 120 | The program that generates these protocol header files is called a _scanner_, and wayland ships with `wayland-scanner`. 121 | For haskell-wayland, you can find the equivalent in `Graphics.Wayland.Scanner`. 122 | Its purpose is to bind to the C wayland interface and marshall all values. 123 | 124 | To have haskell-wayland generate a haskell API to other such XML files (the `wayland.xml` is always generated), you'll want to copy what I did in `Graphics.Wayland.Internal.SpliceClient`, `Graphics.Wayland.Internal.SpliceClientInternal` and `Graphics.Wayland.Internal.SpliceClientTypes`. 125 | The modules `Graphics.Wayland.Internal.SpliceClient` and `Graphics.Wayland.Internal.SpliceClientTypes` should be wholly exposed to the user. 126 | (See `Graphics.Wayland.Client` and notice that `Graphics.Wayland.Internal.SpliceClientInternal` is absent.) 127 | (Ditto for the Server-side.) 128 | 129 | ## Value marshalling ## 130 | 131 | Wherever possible, C values are marshalled to Haskell equivalents. 132 | For the protocol API, this is done by `Graphics.Wayland.Scanner.Marshall`, and for the fixed api manually (but that's mostly trivial). 133 | 134 | The exceptions to this are e.g. the methods that give you access to the memory contained by a buffer (which as of writing I haven't implemented yet). 135 | 136 | 137 | ## Technical notices ## 138 | 139 | In theory, the symbols exposed by the C scanner (`wayland-scanner`) are off-limits for us: every language is supposed to only bind to the C library functions in `libwayland-client` and `libwayland-server`. In other words, the C library functions exposed in `wayland-{client,server,util,egl,cursor}.h`, plus the protocol XML files, should suffice to bind to all of wayland. However, in one occasion we do make us of them (binding a list of `struct wl_interface`s). 140 | 141 | In terms of safety, there are plenty of opportunities with this library to shoot yourself in the foot. 142 | For the most part, on the client side you'll want to stick to C-style event loops with appropriate polls: an example is (somewhat) provided. 143 | Also please don't destroy/release/destruct/... objects more than once. 144 | 145 | 146 | ## Debugging ## 147 | 148 | Try using [wayland-tracker](https://github.com/01org/wayland-tracker) if your code won't work at all: it is a program that can dump the connection between a server and a client. 149 | 150 | 151 | ## TODO ## 152 | 153 | - prettify binding to wl_registry.bind (ie make more type-safe, add haskell documentation, etc) 154 | - some kind of fancy FRP library binding? 155 | - write documentation strings from .protocol files into haddock??? 156 | - allow easy building of other .protocol files into haskell bindings 157 | - protocol version checker function 158 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /hayland.cabal: -------------------------------------------------------------------------------- 1 | -- Initial haskell-wayland.cabal generated by cabal init. For further 2 | -- documentation, see http://haskell.org/cabal/users-guide/ 3 | 4 | name: hayland 5 | version: 0.1.0.1 6 | synopsis: Haskell bindings for the C Wayland library. 7 | description: This package contains bindings to the Wayland library, which is used to interface display devices, drawable clients, and window managers. 8 | . 9 | Wayland exposes a fixed set of functions, and additionally generates a (large) part of its API from a _protocol_ file using Template Haskell. 10 | This package locates that protocol file using @pkg-config@. 11 | . 12 | If you want to interface with other protocols (such as Weston's), refer to the readme for instructions. 13 | license: MIT 14 | license-file: LICENSE 15 | author: Auke Booij 16 | maintainer: auke@tulcod.com 17 | -- copyright: 18 | category: Graphics 19 | build-type: Custom 20 | extra-source-files: README.md, NOTES.md 21 | cabal-version: >=1.10 22 | 23 | source-repository head 24 | type: git 25 | location: https://github.com/tulcod/haskell-wayland 26 | 27 | library 28 | exposed-modules: 29 | Graphics.Wayland, 30 | Graphics.Wayland.Client, 31 | Graphics.Wayland.Server, 32 | Graphics.Wayland.Scanner 33 | other-modules: 34 | Graphics.Wayland.Internal, 35 | Graphics.Wayland.Internal.Client, 36 | Graphics.Wayland.Internal.Cursor, 37 | Graphics.Wayland.Internal.EGL, 38 | Graphics.Wayland.Internal.ServerClientState, 39 | Graphics.Wayland.Internal.Server, 40 | Graphics.Wayland.Internal.Util, 41 | Graphics.Wayland.Internal.Version, 42 | Graphics.Wayland.Internal.SpliceClient, 43 | Graphics.Wayland.Internal.SpliceServer, 44 | Graphics.Wayland.Internal.SpliceClientTypes, 45 | Graphics.Wayland.Internal.SpliceServerTypes, 46 | Graphics.Wayland.Internal.SpliceClientInternal, 47 | Graphics.Wayland.Internal.SpliceServerInternal, 48 | Graphics.Wayland.Scanner.Marshaller, 49 | Graphics.Wayland.Scanner.Names, 50 | Graphics.Wayland.Scanner.Protocol, 51 | Graphics.Wayland.Scanner.Types 52 | build-depends: base >=4.7 && <5, xml >= 1.3 && < 1.4, process >= 1.1 && < 2, template-haskell >= 2 && < 3, data-flags <0.1, time <1.6, transformers < 0.5 53 | build-tools: c2hs >= 0.15, pkg-config 54 | default-extensions: ForeignFunctionInterface 55 | -- hs-source-dirs: 56 | default-language: Haskell2010 57 | cc-options: -fPIC 58 | -- ghc-options: -ddump-splices 59 | pkgconfig-depends: 60 | wayland-client, 61 | wayland-cursor, 62 | wayland-egl, 63 | wayland-server 64 | includes: 65 | wayland-client.h, 66 | wayland-server.h, 67 | wayland-client-protocol.h, 68 | wayland-server-protocol.h, 69 | wayland-util.h, 70 | wayland-version.h, 71 | wayland-egl.h 72 | 73 | -- FIXME: this tests assumes there's a wayland server (e.g. weston) running. 74 | test-suite firsttest 75 | hs-source-dirs: tests 76 | type: exitcode-stdio-1.0 77 | main-is: test.hs 78 | build-depends: base, hayland, xml, process 79 | default-language: Haskell2010 80 | 81 | test-suite enumtest 82 | hs-source-dirs: tests 83 | type: exitcode-stdio-1.0 84 | main-is: enums.hs 85 | build-depends: base, hayland, xml, process 86 | default-language: Haskell2010 87 | 88 | executable wayland-list-globals 89 | hs-source-dirs: tests 90 | main-is: listglobals.hs 91 | build-depends: base, hayland 92 | default-language: Haskell2010 93 | -------------------------------------------------------------------------------- /tests/enums.hs: -------------------------------------------------------------------------------- 1 | import Graphics.Wayland.Client 2 | 3 | a :: DisplayError 4 | a = displayErrorInvalidMethod 5 | 6 | main = print a 7 | -------------------------------------------------------------------------------- /tests/listglobals.hs: -------------------------------------------------------------------------------- 1 | import Control.Concurrent 2 | 3 | import Graphics.Wayland.Client 4 | 5 | main = do 6 | connect <- displayConnect 7 | let display = case connect of 8 | Just x -> x 9 | Nothing -> error "couldn't connect to a wayland server." 10 | fd <- displayGetFd display 11 | putStrLn $ "Using file descriptor " ++ show fd 12 | putStrLn $ "Display at " ++ show display 13 | registry <- displayGetRegistry display 14 | putStrLn $ "Registry at "++ show registry 15 | let listener = RegistryListener { 16 | registryGlobal = \reg name ifacename version -> putStrLn $ "Received global " ++ show name ++ " (" ++ ifacename ++ ") version " ++ show version, 17 | registryGlobalRemove = \ _ _ -> return () 18 | } 19 | errorCode <- registrySetListener registry listener 20 | putStrLn $ "Setting registry listener... " ++ show errorCode 21 | 22 | res <- displayPrepareRead display 23 | putStrLn $ "Preparing read... " ++ show res 24 | flushed <- displayFlush display 25 | putStrLn $ "Flushed " ++ show flushed 26 | putStrLn "polling" 27 | threadWaitRead fd 28 | putStrLn $ "Ready to read." 29 | events <- displayReadEvents display 30 | putStrLn $ "Read display events: " ++ show events 31 | dispatched <- displayDispatchPending display 32 | putStrLn $ "Dispatched events: " ++ show dispatched 33 | displayDisconnect display 34 | -------------------------------------------------------------------------------- /tests/test.hs: -------------------------------------------------------------------------------- 1 | import Control.Concurrent 2 | 3 | import Graphics.Wayland (scannedVersionOf) 4 | import Graphics.Wayland.Client 5 | 6 | main = do 7 | connect <- displayConnect 8 | print connect 9 | let display = case connect of 10 | Just x -> x 11 | Nothing -> error "could not connect to a wayland server" 12 | 13 | putStrLn $ "Using Display with scanned version "++ (show $ scannedVersionOf display) 14 | putStrLn $ "Using Surface with scanned version "++ (show $ scannedVersionOf (undefined::Surface)) 15 | 16 | b <- displaySync display 17 | print b 18 | let listener = CallbackListener { 19 | callbackDone = \ _ _ -> putStrLn "received done" 20 | } 21 | callbackSetListener b listener 22 | displayFlush display 23 | displayGetFd display >>= threadWaitRead 24 | displayDispatch display 25 | --------------------------------------------------------------------------------