packages feed

hayland (empty) → 0.1.0.0

raw patch · 30 files changed

+2443/−0 lines, 30 filesdep +basedep +data-flagsdep +haylandbuild-type:Customsetup-changed

Dependencies added: base, data-flags, hayland, process, template-haskell, time, xml

Files

+ Graphics/Wayland.hs view
@@ -0,0 +1,15 @@+module Graphics.Wayland (+  version, Fixed256, Precision256, Time, Result(..), errToResult,+  diffTimeToTime, timeToDiffTime+  ) where++import Foreign.C.Types++import Graphics.Wayland.Internal.Util+import Graphics.Wayland.Internal.Version+++data Result = Success | Failure deriving (Eq, Show)+errToResult :: CInt -> Result+errToResult 0    = Success+errToResult (-1) = Failure
+ Graphics/Wayland/Client.hs view
@@ -0,0 +1,13 @@+module Graphics.Wayland.Client (+  module Graphics.Wayland.Internal.Client,  -- this will need to be removed when the lib is at a more complete state+  module Graphics.Wayland.Internal.SpliceClient,+  module Graphics.Wayland.Internal.SpliceClientTypes,+  module Graphics.Wayland.Internal.Cursor,+  module Graphics.Wayland.Internal.EGL+  ) where++import Graphics.Wayland.Internal.Client+import Graphics.Wayland.Internal.SpliceClient+import Graphics.Wayland.Internal.SpliceClientTypes+import Graphics.Wayland.Internal.Cursor+import Graphics.Wayland.Internal.EGL
+ Graphics/Wayland/Internal.hs view
@@ -0,0 +1,1 @@+module Graphics.Wayland.Internal where
+ Graphics/Wayland/Internal/Client.chs view
@@ -0,0 +1,185 @@+module Graphics.Wayland.Internal.Client (+  Result(..),++  displayConnect, displayConnectName, displayConnectFd, displayDisconnect, displayGetFd,+  displayDispatch, displayDispatchPending,++  displayGetError, displayFlush, displayRoundtrip,++  displayPrepareRead, displayCancelRead, displayReadEvents+  ) where++import Foreign+import Foreign.C.Types+import Foreign.C.String+import System.Posix.Types++import Graphics.Wayland.Internal.SpliceClientInternal+import Graphics.Wayland.Internal.SpliceClient+import Graphics.Wayland.Internal.SpliceClientTypes+import Graphics.Wayland+++#include <wayland-client.h>++{#context prefix="wl"#}++unFd :: Fd -> CInt+unFd (Fd k) = k++makeWith' :: b -> (b -> IO c) -> IO c+makeWith' b f = f b++withNullPtr = makeWith' nullPtr++codeToNothing :: Int -> Int -> Maybe Int+codeToNothing j k+  | j == k    = Nothing+  | otherwise = Just k++codeNeg1ToNothing :: CInt -> Maybe Int+codeNeg1ToNothing = codeToNothing (-1) . fromIntegral++code0ToNothing    :: CInt -> Maybe Int+code0ToNothing    = codeToNothing 0    . fromIntegral++-- Data types++-- In the case of the Client side, these are all just abstract pointer objects.++-- struct wl_display pointer (nocode since its interface is generated in SpliceProtocol)+{#pointer * display as Display nocode#}++-- -- | struct wl_event_queue pointer (generate type since this is not an interface)+-- {#pointer * event_queue as EventQueue newtype#}++-- -- | struct wl_interface pointer. for internal use only. (proxy typing)+-- {#pointer * interface as Interface newtype#}++++-- Functions/methods+++-- -- void wl_event_queue_destroy(struct wl_event_queue *queue);+-- {#fun unsafe event_queue_destroy as ^ {`EventQueue'} -> `()'#}++-- void wl_proxy_marshal(struct wl_proxy *p, uint32_t opcode, ...);++-- void wl_proxy_marshal_array(struct wl_proxy *p, uint32_t opcode,+--                               union wl_argument *args);++-- struct wl_proxy *wl_proxy_create(struct wl_proxy *factory,+--                                    const struct wl_interface *interface);++-- struct wl_proxy *wl_proxy_marshal_constructor(struct wl_proxy *proxy,+--                                               uint32_t opcode,+--                                               const struct wl_interface *interface,+--                                               ...);+-- struct wl_proxy *+-- wl_proxy_marshal_array_constructor(struct wl_proxy *proxy,+--                                    uint32_t opcode, union wl_argument *args,+--                                    const struct wl_interface *interface);++-- void wl_proxy_destroy(struct wl_proxy *proxy);+-- int wl_proxy_add_listener(struct wl_proxy *proxy,+--                           void (**implementation)(void), void *data);+-- const void *wl_proxy_get_listener(struct wl_proxy *proxy);+-- int wl_proxy_add_dispatcher(struct wl_proxy *proxy,+--                             wl_dispatcher_func_t dispatcher_func,+--                             const void * dispatcher_data, void *data);+-- void wl_proxy_set_user_data(struct wl_proxy *proxy, void *user_data);+-- void *wl_proxy_get_user_data(struct wl_proxy *proxy);+-- uint32_t wl_proxy_get_id(struct wl_proxy *proxy);+-- const char *wl_proxy_get_class(struct wl_proxy *proxy);+-- void wl_proxy_set_queue(struct wl_proxy *proxy, struct wl_event_queue *queue);+++receiveMaybeDisplay :: Display -> Maybe Display+receiveMaybeDisplay (Display x)+  | x == nullPtr = Nothing+  | otherwise    = Just (Display x)++-- struct wl_display *wl_display_connect(const char *name);+-- | Connect to a display with a specified name+{#fun unsafe display_connect as displayConnectName {`String'} -> `Maybe Display' receiveMaybeDisplay #}++-- | Connect to the default display by passing a null pointer+{#fun unsafe display_connect as displayConnect {withNullPtr- `Ptr CChar'} -> `Maybe Display' receiveMaybeDisplay #}++-- struct wl_display *wl_display_connect_to_fd(int fd);+-- | Connect to a display by file descriptor+{#fun unsafe display_connect_to_fd as displayConnectFd {unFd `Fd'} -> `Maybe Display' receiveMaybeDisplay #}++-- void wl_display_disconnect(struct wl_display *display);+{#fun unsafe display_disconnect as displayDisconnect {`Display'} -> `()' #}++-- int wl_display_get_fd(struct wl_display *display);+{#fun unsafe display_get_fd as displayGetFd {`Display'} -> `Fd' Fd #}++-- int wl_display_dispatch(struct wl_display *display);+-- | wl_display_dispatch. Returns @Nothing@ on failure or @Just k@ if k events were processed.+--+-- Strictly safe!!! This *will* call back into Haskell code!+{#fun display_dispatch as displayDispatch {`Display'} -> `Maybe Int' codeNeg1ToNothing #}++-- -- int wl_display_dispatch_queue(struct wl_display *display,+-- --                               struct wl_event_queue *queue);+-- -- | wl_display_dispatch_queue. Returns @Nothing@ on failure or @Just k@ if k events were processed.+-- --+-- -- Strictly safe!!! This *will* call back into Haskell code!+-- {#fun display_dispatch_queue as displayDispatchQueue {`Display', `EventQueue'} -> `Maybe Int' codeNeg1ToNothing #}++-- -- int wl_display_dispatch_queue_pending(struct wl_display *display,+-- --                                       struct wl_event_queue *queue);+-- -- | wl_display_dispatch_queue_pending. Returns @Nothing@ on failure or @Just k@ if k events were processed.+-- --+-- -- Strictly safe!!! This *will* call back into Haskell code!+-- {#fun display_dispatch_queue_pending as displayDispatchQueuePending {`Display', `EventQueue'} -> `Maybe Int' codeNeg1ToNothing #}++-- int wl_display_dispatch_pending(struct wl_display *display);+-- | wl_display_dispatch_pending. Returns @Nothing@ on failure or @Just k@ if k events were processed.+--+-- Strictly safe!!! This *will* call back into Haskell code!+{#fun display_dispatch_pending as displayDispatchPending {`Display'} -> `Maybe Int' codeNeg1ToNothing #}++-- int wl_display_get_error(struct wl_display *display);+-- | @Nothing@ if no error occurred or @Just k@ if the latest error had code k+--+-- Note (from the wayland documentation): errors are fatal. If this function returns a @Just@ value, the display can no longer be used.+{#fun unsafe display_get_error as displayGetError {`Display'} -> `Maybe Int' code0ToNothing #}++-- int wl_display_flush(struct wl_display *display);+-- | @Nothing@ on failure or @Just k@ if k bytes were sent+--+-- __It is not clear to me if this is can be unsafe (ie. can this call back into haskell code?).__+{#fun display_flush as displayFlush {`Display'} -> `Maybe Int' codeNeg1ToNothing #}++-- int wl_display_roundtrip(struct wl_display *display);+-- | @Nothing@ on failure or @Just k@ if k events were dispatched.+--+-- __It is not clear to me if this is can be unsafe (ie. can this call back into haskell code?).__+{#fun display_roundtrip as displayRoundtrip {`Display'} -> `Maybe Int' codeNeg1ToNothing #}++-- -- struct wl_event_queue *wl_display_create_queue(struct wl_display *display);+-- -- | Docs say that wl_display_create_queue may return NULL on failure, but that only happens when it's out of memory+-- {#fun unsafe display_create_queue as displayCreateQueue {`Display'} -> `EventQueue' #}++-- -- int wl_display_prepare_read_queue(struct wl_display *display,+-- --                                   struct wl_event_queue *queue);+-- {#fun unsafe display_prepare_read_queue as displayPrepareReadQueue {`Display', `EventQueue'} -> `Result' errToResult #}++-- int wl_display_prepare_read(struct wl_display *display);+{#fun unsafe display_prepare_read as displayPrepareRead {`Display'} -> `Result' errToResult #}++-- void wl_display_cancel_read(struct wl_display *display);+{#fun unsafe display_cancel_read as displayCancelRead {`Display'} -> `()' #}++-- int wl_display_read_events(struct wl_display *display);+-- | This will read events from the file descriptor for the display.+--   This function does not dispatch events, it only reads and queues events into their corresponding event queues.+--+--   Before calling this function, wl_display_prepare_read() must be called first.+{#fun unsafe display_read_events as displayReadEvents {`Display'} -> `Result' errToResult #}++-- void wl_log_set_handler_client(wl_log_func_t handler);
+ Graphics/Wayland/Internal/Cursor.chs view
@@ -0,0 +1,95 @@+-- | This is client-side code for loading cursor themes. Provided for convenience only.+module Graphics.Wayland.Internal.Cursor (+  CursorTheme, CursorImage, Cursor,+  cursorImageSize, cursorImageHotspot, cursorImageDelay,+  cursorName, cursorImages,++  cursorThemeLoad, cursorThemeDestroy, cursorThemeGetCursor, cursorImageGetBuffer, cursorFrame+  ) where++import Control.Monad (liftM)+import Foreign+import Foreign.C.Types+import Foreign.C.String+import System.IO.Unsafe (unsafePerformIO)++import Graphics.Wayland.Internal.SpliceClientTypes (Shm(..), Buffer(..))++#include <wayland-cursor.h>++{#context prefix="wl"#}+++-- | struct wl_cursor_theme;+{#pointer * cursor_theme as CursorTheme newtype#}+++-- | struct wl_cursor_image {+-- 	uint32_t width;		/* actual width */+-- 	uint32_t height;	/* actual height */+-- 	uint32_t hotspot_x;	/* hot spot x (must be inside image) */+-- 	uint32_t hotspot_y;	/* hot spot y (must be inside image) */+-- 	uint32_t delay;		/* animation delay to next frame (ms) */+-- };+{#pointer * cursor_image as CursorImage newtype#}++cursorImageSize :: CursorImage -> (Word, Word)+cursorImageSize (CursorImage ci) = unsafePerformIO $ do -- CursorImages are immutable+  width <- {#get cursor_image->width#} ci+  height <- {#get cursor_image->height#} ci+  return (fromIntegral width, fromIntegral height)++cursorImageHotspot :: CursorImage -> (Word, Word)+cursorImageHotspot (CursorImage ci) = unsafePerformIO $ do -- CursorImages are immutable+  x <- {#get cursor_image->hotspot_x#} ci+  y <- {#get cursor_image->hotspot_y#} ci+  return (fromIntegral x, fromIntegral y)++cursorImageDelay :: CursorImage -> Word+cursorImageDelay (CursorImage ci) = unsafePerformIO $ liftM fromIntegral $ {#get cursor_image->delay#} ci -- CursorImages are immutable++-- | struct wl_cursor {+-- 	unsigned int image_count;+-- 	struct wl_cursor_image **images;+-- 	char *name;+-- };+{#pointer * cursor as Cursor newtype#}+cursorName :: Cursor -> String+cursorName (Cursor c) = unsafePerformIO $ do+  cstr <- {#get cursor->name#} c+  peekCString cstr++cursorImages :: Cursor -> [CursorImage]+cursorImages (Cursor c) = unsafePerformIO $ do+  imagesPtr <- (\ ptr -> (peekByteOff ptr {#offsetof cursor->images#} :: IO (Ptr (Ptr CursorImage)))) c+  count <- {#get cursor->image_count#} c+  return imagesPtr+  ptrs <- peekArray (fromIntegral count) imagesPtr+  return $ map CursorImage ptrs++-- struct wl_shm;+{#pointer * shm as Shm nocode#}++-- | struct wl_cursor_theme *+-- wl_cursor_theme_load(const char *name, int size, struct wl_shm *shm);+{#fun unsafe cursor_theme_load as cursorThemeLoad {`String', `Int', `Shm'} -> `CursorTheme'#}++-- | void+-- wl_cursor_theme_destroy(struct wl_cursor_theme *theme);+{#fun unsafe cursor_theme_destroy as cursorThemeDestroy {`CursorTheme'} -> `()' #}++-- | struct wl_cursor *+-- wl_cursor_theme_get_cursor(struct wl_cursor_theme *theme,+-- 			   const char *name);+{#fun unsafe cursor_theme_get_cursor as cursorThemeGetCursor {`CursorTheme', `String'} -> `Cursor' #}++{#pointer * buffer as Buffer nocode#}+-- | struct wl_buffer *+-- wl_cursor_image_get_buffer(struct wl_cursor_image *image);+--+-- From the wayland docs: do not destroy the returned buffer.+{#fun unsafe cursor_image_get_buffer as cursorImageGetBuffer {`CursorImage'} -> `Buffer' #}++-- | int+-- wl_cursor_frame(struct wl_cursor *cursor, uint32_t time);+{#fun unsafe cursor_frame as cursorFrame {`Cursor', `Int'} -> `Int' #}
+ Graphics/Wayland/Internal/EGL.chs view
@@ -0,0 +1,48 @@+-- | Client-side+module Graphics.Wayland.Internal.EGL (+  EGLWindow, eglWindowCreate, eglWindowDestroy, eglWindowResize, eglWindowGetAttachedSize+  ) where+++import Control.Monad+import Foreign+import Foreign.C.Types+import Foreign.C.String++import Graphics.Wayland.Internal.SpliceClientTypes (Surface(..))++#include <wayland-egl.h>++{#context prefix="wl"#}+++-- lol this is 100% unused.+-- #define WL_EGL_PLATFORM 1++{#pointer * surface as Surface nocode#}++-- struct wl_egl_window;+{#pointer * egl_window as EGLWindow newtype#}++-- struct wl_egl_window *+-- wl_egl_window_create(struct wl_surface *surface,+-- 		     int width, int height);+{#fun unsafe egl_window_create as eglWindowCreate {`Surface', `Int', `Int'} -> `EGLWindow' #}++-- void+-- wl_egl_window_destroy(struct wl_egl_window *egl_window);+{#fun unsafe egl_window_destroy as eglWindowDestroy {`EGLWindow'} -> `()' #}++-- void+-- wl_egl_window_resize(struct wl_egl_window *egl_window,+-- 		     int width, int height,+-- 		     int dx, int dy);+{#fun unsafe egl_window_resize as eglWindowResize {`EGLWindow', `Int', `Int', `Int', `Int'} -> `()' #}+++-- void+-- wl_egl_window_get_attached_size(struct wl_egl_window *egl_window,+-- 				int *width, int *height);+-- withInt = with.fromIntegral 0+peekInt = liftM fromIntegral . peek+{#fun unsafe egl_window_get_attached_size as eglWindowGetAttachedSize {`EGLWindow', alloca- `Int' peekInt*, alloca- `Int' peekInt*} -> `()' #}
+ Graphics/Wayland/Internal/Server.chs view
@@ -0,0 +1,576 @@+-- Trying my best to piss off the Safe Haskell guys+{-# LANGUAGE TemplateHaskell, GeneralizedNewtypeDeriving #-}+module Graphics.Wayland.Internal.Server (+  ClientState(..), clientStateReadable, clientStateWritable, clientStateHangup,+  clientStateError,++  EventLoop, EventSource,++  EventLoopFdFunc, EventLoopTimerFunc, EventLoopSignalFunc, EventLoopIdleFunc,++  eventLoopCreate, eventLoopDestroy, eventLoopAddFd, eventSourceFdUpdate,+  eventLoopAddTimer, eventLoopAddSignal, eventSourceTimerUpdate, eventSourceRemove,+  eventSourceCheck, eventLoopDispatch, eventLoopDispatchIdle, eventLoopAddIdle, eventLoopGetFd,++  DisplayServer, displayCreate, displayDestroy, displayGetEventLoop, displayAddSocket,+  displayTerminate, displayRun, displayFlushClients, displayGetSerial, displayNextSerial,++  clientCreate, clientDestroy, clientFlush, clientGetCredentials, clientPostNoMemory,++  ShmBuffer, shmBufferBeginAccess, shmBufferEndAccess, shmBufferGet, shmBufferGetData,+  shmBufferGetStride, shmBufferGetFormat, shmBufferGetWidth, shmBufferGetHeight,+  displayInitShm, displayAddShmFormat, shmBufferCreate+  ) where++import Control.Monad (liftM)+import Data.Functor ((<$>))+import Data.Flags+import Data.Flags.TH+import Foreign+import Foreign.C.Types+import Foreign.C.String+import System.Posix.Types++import Graphics.Wayland.Internal.ServerClientState -- for the WL_EVENT_* constants+import Graphics.Wayland.Internal.SpliceServerInternal+import Graphics.Wayland.Internal.SpliceServer+import Graphics.Wayland.Internal.SpliceServerTypes+import Graphics.Wayland.Internal.Util (Client(..))+import Graphics.Wayland+++#include <wayland-server.h>++{#context prefix="wl"#}++++++boolToCInt :: Bool -> CInt+boolToCInt True = 1+boolToCInt False = 0++++unFd :: Fd -> CInt+unFd (Fd n) = n++makeWith :: (a -> IO b) -> (a -> (b -> IO c) -> IO c)+makeWith func = \ a f -> do+  b <- func a+  f b++makeWith' :: b -> (b -> IO c) -> IO c+makeWith' b f = f b++withNullPtr = makeWith' nullPtr++-- | enum {+-- 	WL_EVENT_READABLE = 0x01,+-- 	WL_EVENT_WRITABLE = 0x02,+-- 	WL_EVENT_HANGUP   = 0x04,+-- 	WL_EVENT_ERROR    = 0x08+-- };+--+-- The "uint32_t mask" argument passed to a variety of functions in this file is a bitmask+-- detailing the state of the client.+$(bitmaskWrapper "ClientState" ''CUInt [''Num, ''Integral, ''Real, ''Enum, ''Ord] [+  ("clientStateReadable", fromIntegral $ fromEnum ClientReadable),+  ("clientStateWritable", fromIntegral $  fromEnum ClientWritable),+  ("clientStateHangup",   fromIntegral $  fromEnum ClientHangup),+  ("clientStateError",    fromIntegral $  fromEnum ClientError)+  ])++-- | struct wl_event_loop;+{#pointer * event_loop as EventLoop newtype#}++-- | struct wl_event_source;+{#pointer * event_source as EventSource newtype#}++type CEventLoopFdFunc = CInt -> {#type uint32_t#} -> Ptr () -> IO CInt+-- | typedef int (*wl_event_loop_fd_func_t)(int fd, uint32_t mask, void *data);+type EventLoopFdFunc = Int -> ClientState -> IO Bool+foreign import ccall unsafe "wrapper" makeFdFunPtr :: CEventLoopFdFunc -> IO (FunPtr CEventLoopFdFunc)+marshallEventLoopFdFunc :: EventLoopFdFunc -> IO (FunPtr CEventLoopFdFunc)+marshallEventLoopFdFunc func = makeFdFunPtr $ \ fd mask _ -> boolToCInt <$> func (fromIntegral fd) (fromIntegral mask)+melff = makeWith marshallEventLoopFdFunc++type CEventLoopTimerFunc = Ptr () -> IO CInt+-- | typedef int (*wl_event_loop_timer_func_t)(void *data);+type EventLoopTimerFunc = IO Bool+foreign import ccall unsafe "wrapper" makeTimerFunPtr :: CEventLoopTimerFunc -> IO (FunPtr CEventLoopTimerFunc)+marshallEventLoopTimerFunc :: EventLoopTimerFunc -> IO (FunPtr CEventLoopTimerFunc)+marshallEventLoopTimerFunc func = makeTimerFunPtr $ \ _ -> boolToCInt <$> func+meltf = makeWith marshallEventLoopTimerFunc++type CEventLoopSignalFunc = CInt -> Ptr () -> IO CInt+-- | typedef int (*wl_event_loop_signal_func_t)(int signal_number, void *data);+type EventLoopSignalFunc = Int -> IO Bool+foreign import ccall unsafe "wrapper" makeSignalFunPtr :: CEventLoopSignalFunc -> IO (FunPtr CEventLoopSignalFunc)+marshallEventLoopSignalFunc :: EventLoopSignalFunc -> IO (FunPtr CEventLoopSignalFunc)+marshallEventLoopSignalFunc func = makeSignalFunPtr $ \ x _ -> boolToCInt <$> func (fromIntegral x)+melsf = makeWith marshallEventLoopSignalFunc++-- typedef void (*wl_event_loop_idle_func_t)(void *data);+type CEventLoopIdleFunc = Ptr () -> IO ()+type EventLoopIdleFunc = IO ()+foreign import ccall unsafe "wrapper" makeIdleFunPtr :: CEventLoopIdleFunc -> IO (FunPtr CEventLoopIdleFunc)+marshallEventLoopIdleFunc :: EventLoopIdleFunc -> IO (FunPtr CEventLoopIdleFunc)+marshallEventLoopIdleFunc func = makeIdleFunPtr $ \ _ -> func+melif = makeWith marshallEventLoopIdleFunc++-- |struct wl_event_loop *wl_event_loop_create(void);+{#fun unsafe event_loop_create as eventLoopCreate {} -> `EventLoop' #}++-- |void wl_event_loop_destroy(struct wl_event_loop *loop);+{#fun unsafe event_loop_destroy as eventLoopDestroy {`EventLoop'} -> `()' #}++-- | struct wl_event_source *wl_event_loop_add_fd(struct wl_event_loop *loop,+-- 					     int fd, uint32_t mask,+-- 					     wl_event_loop_fd_func_t func,+-- 					     void *data);+{#fun unsafe event_loop_add_fd as eventLoopAddFd {`EventLoop', unFd `Fd', fromIntegral `ClientState', melff* `EventLoopFdFunc', withNullPtr- `Ptr ()'} -> `EventSource' #}++-- | int wl_event_source_fd_update(struct wl_event_source *source, uint32_t mask);+{#fun unsafe event_source_fd_update as eventSourceFdUpdate {`EventSource', fromIntegral `ClientState'} -> `Result' errToResult #}++-- | struct wl_event_source *wl_event_loop_add_timer(struct wl_event_loop *loop,+-- 						wl_event_loop_timer_func_t func,+-- 						void *data);+{#fun unsafe event_loop_add_timer as eventLoopAddTimer {`EventLoop', meltf* `EventLoopTimerFunc', withNullPtr- `Ptr ()'} -> `EventSource'#}++-- | struct wl_event_source *+-- wl_event_loop_add_signal(struct wl_event_loop *loop,+-- 			int signal_number,+-- 			wl_event_loop_signal_func_t func,+-- 			void *data);+{#fun unsafe event_loop_add_signal as eventLoopAddSignal {`EventLoop', `Int', melsf* `EventLoopSignalFunc', withNullPtr- `Ptr ()'} -> `EventSource' #}++-- | int wl_event_source_timer_update(struct wl_event_source *source,+-- 				 int ms_delay);+{#fun unsafe event_source_timer_update as eventSourceTimerUpdate {`EventSource', `Int'} -> `Result' errToResult #}++-- | int wl_event_source_remove(struct wl_event_source *source);+{#fun unsafe event_source_remove as eventSourceRemove {`EventSource'} -> `()' #}++-- | void wl_event_source_check(struct wl_event_source *source);+{#fun unsafe event_source_check as eventSourceCheck {`EventSource'} -> `()' #}++-- | int wl_event_loop_dispatch(struct wl_event_loop *loop, int timeout);+--+-- SAFE!!+{#fun event_loop_dispatch as eventLoopDispatch {`EventLoop', `Int'} -> `Result' errToResult#}++-- | void wl_event_loop_dispatch_idle(struct wl_event_loop *loop);+{#fun event_loop_dispatch_idle as eventLoopDispatchIdle {`EventLoop'} -> `()' #}++-- | struct wl_event_source *wl_event_loop_add_idle(struct wl_event_loop *loop,+-- 					       wl_event_loop_idle_func_t func,+-- 					       void *data);+{#fun event_loop_add_idle as eventLoopAddIdle {`EventLoop', melif* `EventLoopIdleFunc', withNullPtr- `Ptr ()'} -> `EventSource' #}++-- | int wl_event_loop_get_fd(struct wl_event_loop *loop);+{#fun unsafe event_loop_get_fd as eventLoopGetFd {`EventLoop'} -> `Fd' Fd #}+++-- EXPOSED UNTIL HERE+++-- struct wl_client;+-- defined in .Util+{#pointer * client as Client newtype nocode#}++receiveMaybeClient :: Client -> Maybe Client+receiveMaybeClient (Client x)+  | x == nullPtr = Nothing+  | otherwise    = Just (Client x)++-- |struct wl_display;+--+-- this is called a Compositor in e.g weston, QtWayland+--+-- 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.+{#pointer * display as DisplayServer newtype #}++-- struct wl_listener;+-- struct wl_resource;+-- struct wl_global;++-- typedef void (*wl_notify_func_t)(struct wl_listener *listener, void *data);+-- void wl_event_loop_add_destroy_listener(struct wl_event_loop *loop,+-- 					struct wl_listener * listener);+-- struct wl_listener *wl_event_loop_get_destroy_listener(+-- 					struct wl_event_loop *loop,+-- 					wl_notify_func_t notify);++-- | struct wl_display *wl_display_create(void);+{#fun unsafe display_create as displayCreate {} -> `DisplayServer' #}++-- | void wl_display_destroy(struct wl_display *display);+{#fun unsafe display_destroy as displayDestroy {`DisplayServer'} -> `()' #}++-- | struct wl_event_loop *wl_display_get_event_loop(struct wl_display *display);+{#fun unsafe display_get_event_loop as displayGetEventLoop {`DisplayServer'} -> `EventLoop' #}++-- | int wl_display_add_socket(struct wl_display *display, const char *name);+withMaybeCString :: Maybe String -> (CString -> IO a) -> IO a+withMaybeCString Nothing fun = fun nullPtr+withMaybeCString (Just str) fun = withCString str fun+{#fun unsafe display_add_socket as displayAddSocket {`DisplayServer', withMaybeCString* `Maybe String'} -> `Result' errToResult #}++-- | void wl_display_terminate(struct wl_display *display);+{#fun unsafe display_terminate as displayTerminate {`DisplayServer'} -> `()' #}++-- | void wl_display_run(struct wl_display *display);+--+-- STRICTLY SAFE!!!+{#fun display_run as displayRun {`DisplayServer'} -> `()' #}++-- | void wl_display_flush_clients(struct wl_display *display);+{#fun display_flush_clients as displayFlushClients {`DisplayServer'} -> `()' #}++-- typedef void (*wl_global_bind_func_t)(struct wl_client *client, void *data,+-- 				      uint32_t version, uint32_t id);++-- not sure what these two functions are for+-- | uint32_t wl_display_get_serial(struct wl_display *display);+{#fun unsafe display_get_serial as displayGetSerial {`DisplayServer'} -> `Word' fromIntegral #}++-- | uint32_t wl_display_next_serial(struct wl_display *display);+{#fun unsafe display_next_serial as displayNextSerial {`DisplayServer'} -> `Word' fromIntegral #}++-- void wl_display_add_destroy_listener(struct wl_display *display,+-- 				     struct wl_listener *listener);+-- struct wl_listener *wl_display_get_destroy_listener(struct wl_display *display,+-- 						    wl_notify_func_t notify);++-- struct wl_global *wl_global_create(struct wl_display *display,+-- 				   const struct wl_interface *interface,+-- 				   int version,+-- 				   void *data, wl_global_bind_func_t bind);+-- void wl_global_destroy(struct wl_global *global);++-- | struct wl_client *wl_client_create(struct wl_display *display, int fd);+{#fun unsafe client_create as clientCreate {`DisplayServer', unFd `Fd'} -> `Maybe Client' receiveMaybeClient #}++-- | void wl_client_destroy(struct wl_client *client);+{#fun unsafe client_destroy as clientDestroy {`Client'} -> `()' #}++-- | void wl_client_flush(struct wl_client *client);+{#fun unsafe client_flush as clientFlush {`Client'} -> `()' #}++peekPid = liftM CPid . liftM fromIntegral . peek+peekUid = liftM CUid . liftM fromIntegral . peek+peekGid = liftM CGid . liftM fromIntegral . peek+-- | void wl_client_get_credentials(struct wl_client *client,+-- 			       pid_t *pid, uid_t *uid, gid_t *gid);+{#fun unsafe client_get_credentials as clientGetCredentials {`Client', alloca- `ProcessID' peekPid*, alloca- `UserID' peekUid*, alloca- `GroupID' peekGid*} -> `()' #}++-- void wl_client_add_destroy_listener(struct wl_client *client,+-- 				    struct wl_listener *listener);+-- struct wl_listener *wl_client_get_destroy_listener(struct wl_client *client,+-- 						   wl_notify_func_t notify);++-- this function should not be needed+-- struct wl_resource *+-- wl_client_get_object(struct wl_client *client, uint32_t id);+-- void+-- | wl_client_post_no_memory(struct wl_client *client);+{#fun unsafe client_post_no_memory as clientPostNoMemory {`Client'} -> `()' #}++-- /** \class wl_listener+--  *+--  * \brief A single listener for Wayland signals+--  *+--  * wl_listener provides the means to listen for wl_signal notifications. Many+--  * Wayland objects use wl_listener for notification of significant events like+--  * object destruction.+--  *+--  * Clients should create wl_listener objects manually and can register them as+--  * listeners to signals using #wl_signal_add, assuming the signal is+--  * directly accessible. For opaque structs like wl_event_loop, adding a+--  * listener should be done through provided accessor methods. A listener can+--  * only listen to one signal at a time.+--  *+--  * ~~~+--  * struct wl_listener your_listener;+--  *+--  * your_listener.notify = your_callback_method;+--  *+--  * \comment{Direct access}+--  * wl_signal_add(&some_object->destroy_signal, &your_listener);+--  *+--  * \comment{Accessor access}+--  * wl_event_loop *loop = ...;+--  * wl_event_loop_add_destroy_listener(loop, &your_listener);+--  * ~~~+--  *+--  * If the listener is part of a larger struct, #wl_container_of can be used+--  * to retrieve a pointer to it:+--  *+--  * \code+--  * void your_listener(struct wl_listener *listener, void *data)+--  * {+--  * 	struct your_data *data;+--  *+--  * 	your_data = wl_container_of(listener, data, your_member_name);+--  * }+--  * \endcode+--  *+--  * If you need to remove a listener from a signal, use #wl_list_remove.+--  *+--  * \code+--  * wl_list_remove(&your_listener.link);+--  * \endcode+--  *+--  * \sa wl_signal+--  */+-- struct wl_listener {+-- 	struct wl_list link;+-- 	wl_notify_func_t notify;+-- };++-- /** \class wl_signal+--  *+--  * \brief A source of a type of observable event+--  *+--  * Signals are recognized points where significant events can be observed.+--  * Compositors as well as the server can provide signals. Observers are+--  * wl_listener's that are added through #wl_signal_add. Signals are emitted+--  * using #wl_signal_emit, which will invoke all listeners until that+--  * listener is removed by #wl_list_remove (or whenever the signal is+--  * destroyed).+--  *+--  * \sa wl_listener for more information on using wl_signal+--  */+-- struct wl_signal {+-- 	struct wl_list listener_list;+-- };++-- /** Initialize a new \ref wl_signal for use.+--  *+--  * \param signal The signal that will be initialized+--  *+--  * \memberof wl_signal+--  */+-- static inline void+-- wl_signal_init(struct wl_signal *signal)+-- {+-- 	wl_list_init(&signal->listener_list);+-- }++-- /** Add the specified listener to this signal.+--  *+--  * \param signal The signal that will emit events to the listener+--  * \param listener The listener to add+--  *+--  * \memberof wl_signal+--  */+-- static inline void+-- wl_signal_add(struct wl_signal *signal, struct wl_listener *listener)+-- {+-- 	wl_list_insert(signal->listener_list.prev, &listener->link);+-- }++-- /** Gets the listener struct for the specified callback.+--  *+--  * \param signal The signal that contains the specified listener+--  * \param notify The listener that is the target of this search+--  * \return the list item that corresponds to the specified listener, or NULL+--  * if none was found+--  *+--  * \memberof wl_signal+--  */+-- static inline struct wl_listener *+-- wl_signal_get(struct wl_signal *signal, wl_notify_func_t notify)+-- {+-- 	struct wl_listener *l;++-- 	wl_list_for_each(l, &signal->listener_list, link)+-- 		if (l->notify == notify)+-- 			return l;++-- 	return NULL;+-- }++-- /** Emits this signal, notifying all registered listeners.+--  *+--  * \param signal The signal object that will emit the signal+--  * \param data The data that will be emitted with the signal+--  *+--  * \memberof wl_signal+--  */+-- static inline void+-- wl_signal_emit(struct wl_signal *signal, void *data)+-- {+-- 	struct wl_listener *l, *next;++-- 	wl_list_for_each_safe(l, next, &signal->listener_list, link)+-- 		l->notify(l, data);+-- }++-- typedef void (*wl_resource_destroy_func_t)(struct wl_resource *resource);++-- NOTE not binding to deprecated stuff, cause wayland is bad enough as it is.++-- /*+--  * Post an event to the client's object referred to by 'resource'.+--  * 'opcode' is the event number generated from the protocol XML+--  * description (the event name). The variable arguments are the event+--  * parameters, in the order they appear in the protocol XML specification.+--  *+--  * The variable arguments' types are:+--  * - type=uint: 	uint32_t+--  * - type=int:		int32_t+--  * - type=fixed:	wl_fixed_t+--  * - type=string:	(const char *) to a nil-terminated string+--  * - type=array:	(struct wl_array *)+--  * - type=fd:		int, that is an open file descriptor+--  * - type=new_id:	(struct wl_object *) or (struct wl_resource *)+--  * - type=object:	(struct wl_object *) or (struct wl_resource *)+--  */+-- void wl_resource_post_event(struct wl_resource *resource,+-- 			    uint32_t opcode, ...);+-- void wl_resource_post_event_array(struct wl_resource *resource,+-- 				  uint32_t opcode, union wl_argument *args);+-- void wl_resource_queue_event(struct wl_resource *resource,+-- 			     uint32_t opcode, ...);+-- void wl_resource_queue_event_array(struct wl_resource *resource,+-- 				   uint32_t opcode, union wl_argument *args);++-- /* msg is a printf format string, variable args are its args. */+-- void wl_resource_post_error(struct wl_resource *resource,+-- 			    uint32_t code, const char *msg, ...)+-- 	__attribute__ ((format (printf, 3, 4)));+-- void wl_resource_post_no_memory(struct wl_resource *resource);++-- #include "wayland-server-protocol.h"++-- struct wl_display *+-- wl_client_get_display(struct wl_client *client);++-- struct wl_resource *+-- wl_resource_create(struct wl_client *client,+-- 		   const struct wl_interface *interface,+-- 		   int version, uint32_t id);+-- void+-- wl_resource_set_implementation(struct wl_resource *resource,+-- 			       const void *implementation,+-- 			       void *data,+-- 			       wl_resource_destroy_func_t destroy);+-- void+-- wl_resource_set_dispatcher(struct wl_resource *resource,+-- 			   wl_dispatcher_func_t dispatcher,+-- 			   const void *implementation,+-- 			   void *data,+-- 			   wl_resource_destroy_func_t destroy);++-- void+-- wl_resource_destroy(struct wl_resource *resource);+-- uint32_t+-- wl_resource_get_id(struct wl_resource *resource);+-- struct wl_list *+-- wl_resource_get_link(struct wl_resource *resource);+-- struct wl_resource *+-- wl_resource_from_link(struct wl_list *resource);+-- struct wl_resource *+-- wl_resource_find_for_client(struct wl_list *list, struct wl_client *client);+-- struct wl_client *+-- wl_resource_get_client(struct wl_resource *resource);+-- void+-- wl_resource_set_user_data(struct wl_resource *resource, void *data);+-- void *+-- wl_resource_get_user_data(struct wl_resource *resource);+-- int+-- wl_resource_get_version(struct wl_resource *resource);+-- void+-- wl_resource_set_destructor(struct wl_resource *resource,+-- 			   wl_resource_destroy_func_t destroy);+-- int+-- wl_resource_instance_of(struct wl_resource *resource,+-- 			const struct wl_interface *interface,+-- 			const void *implementation);++-- void+-- wl_resource_add_destroy_listener(struct wl_resource *resource,+-- 				 struct wl_listener * listener);+-- struct wl_listener *+-- wl_resource_get_destroy_listener(struct wl_resource *resource,+-- 				 wl_notify_func_t notify);++-- #define wl_resource_for_each(resource, list)					\+-- 	for (resource = 0, resource = wl_resource_from_link((list)->next);	\+-- 	     wl_resource_get_link(resource) != (list);				\+-- 	     resource = wl_resource_from_link(wl_resource_get_link(resource)->next))++-- #define wl_resource_for_each_safe(resource, tmp, list)					\+-- 	for (resource = 0, tmp = 0,							\+-- 	     resource = wl_resource_from_link((list)->next),	\+-- 	     tmp = wl_resource_from_link((list)->next->next);	\+-- 	     wl_resource_get_link(resource) != (list);				\+-- 	     resource = tmp,							\+-- 	     tmp = wl_resource_from_link(wl_resource_get_link(resource)->next))+++-- this is a dirty hack to make shmBufferGet accept a Buffer+{#pointer * resource as Buffer newtype nocode#}+-- struct wl_shm_buffer;+{#pointer * shm_buffer as ShmBuffer newtype#}+receiveMaybeShmBuffer :: ShmBuffer -> Maybe ShmBuffer+receiveMaybeShmBuffer (ShmBuffer x)+  | x == nullPtr = Nothing+  | otherwise    = Just (ShmBuffer x)++-- | void+-- wl_shm_buffer_begin_access(struct wl_shm_buffer *buffer);+--+-- Lock the memory for reading. Needed to protect the server against SIGBUS signals+-- caused by the client resizing the buffer.+{#fun unsafe shm_buffer_begin_access as shmBufferBeginAccess {`ShmBuffer'} -> `()' #}++-- |void+-- wl_shm_buffer_end_access(struct wl_shm_buffer *buffer);+--+-- Unlock the memory.+{#fun unsafe shm_buffer_end_access as shmBufferEndAccess {`ShmBuffer'} -> `()' #}++-- | struct wl_shm_buffer *+-- wl_shm_buffer_get(struct wl_resource *resource);+{#fun unsafe shm_buffer_get as shmBufferGet {`Buffer'} -> `Maybe ShmBuffer' receiveMaybeShmBuffer #}++-- | void *+-- wl_shm_buffer_get_data(struct wl_shm_buffer *buffer);+{#fun unsafe shm_buffer_get_data as shmBufferGetData {`ShmBuffer'} -> `Ptr ()' id #}++-- | int32_t+-- wl_shm_buffer_get_stride(struct wl_shm_buffer *buffer);+{#fun unsafe shm_buffer_get_stride as shmBufferGetStride {`ShmBuffer'} -> `Int' #}++-- | uint32_t+-- wl_shm_buffer_get_format(struct wl_shm_buffer *buffer);+{#fun unsafe shm_buffer_get_format as shmBufferGetFormat {`ShmBuffer'} -> `Word' fromIntegral#}++-- | int32_t+-- wl_shm_buffer_get_width(struct wl_shm_buffer *buffer);+{#fun unsafe shm_buffer_get_width as shmBufferGetWidth {`ShmBuffer'} -> `Int' #}++-- | int32_t+-- wl_shm_buffer_get_height(struct wl_shm_buffer *buffer);+{#fun unsafe shm_buffer_get_height as shmBufferGetHeight {`ShmBuffer'} -> `Int' #}++-- | int+-- wl_display_init_shm(struct wl_display *display);+{#fun unsafe display_init_shm as displayInitShm {`DisplayServer'} -> `Result' errToResult #}++-- | uint32_t *+-- wl_display_add_shm_format(struct wl_display *display, uint32_t format);+{#fun unsafe display_add_shm_format as displayAddShmFormat {`DisplayServer', fromIntegral `Word'} -> `()' #}++-- | struct wl_shm_buffer *+-- wl_shm_buffer_create(struct wl_client *client,+-- 		     uint32_t id, int32_t width, int32_t height,+-- 		     int32_t stride, uint32_t format);+{#fun unsafe shm_buffer_create as shmBufferCreate {`Client', fromIntegral `Word', fromIntegral `Word', `Int', `Int', fromIntegral `Word'} -> `Maybe ShmBuffer' receiveMaybeShmBuffer#}++-- void wl_log_set_handler_server(wl_log_func_t handler);
+ Graphics/Wayland/Internal/ServerClientState.chs view
@@ -0,0 +1,9 @@+module Graphics.Wayland.Internal.ServerClientState where++#include <wayland-server.h>++{#enum define ClientStateNums {+  WL_EVENT_READABLE as ClientReadable,+  WL_EVENT_WRITABLE as ClientWritable,+  WL_EVENT_HANGUP as ClientHangup,+  WL_EVENT_ERROR as ClientError} #}
+ Graphics/Wayland/Internal/SpliceClient.hs view
@@ -0,0 +1,17 @@+{-# LANGUAGE TemplateHaskell, ForeignFunctionInterface #-}++module Graphics.Wayland.Internal.SpliceClient where++import Data.Functor+import Language.Haskell.TH+import Foreign.C.Types++import Graphics.Wayland.Scanner.Protocol+import Graphics.Wayland.Scanner+import Graphics.Wayland.Internal.SpliceClientInternal+import Graphics.Wayland.Internal.SpliceClientTypes+++$(runIO readProtocol >>= generateClientExternalMethods)+$(runIO readProtocol >>= generateClientExternalListeners)+$(runIO readProtocol >>= generateRegistryBindExternal)
+ Graphics/Wayland/Internal/SpliceClientInternal.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE TemplateHaskell, ForeignFunctionInterface #-}++module Graphics.Wayland.Internal.SpliceClientInternal where++import Data.Functor+import Language.Haskell.TH+import Foreign.C.Types++import Graphics.Wayland.Scanner.Protocol+import Graphics.Wayland.Scanner+import Graphics.Wayland.Internal.SpliceClientTypes+++$(runIO readProtocol >>= generateClientInternalMethods)+$(runIO readProtocol >>= generateClientInternalListeners)+$(runIO readProtocol >>= generateRegistryBindInternal)
+ Graphics/Wayland/Internal/SpliceClientTypes.hs view
@@ -0,0 +1,13 @@+{-# LANGUAGE TemplateHaskell, ForeignFunctionInterface #-}++module Graphics.Wayland.Internal.SpliceClientTypes where++import Data.Functor+import Language.Haskell.TH+import Foreign.C.Types++import Graphics.Wayland.Scanner.Protocol+import Graphics.Wayland.Scanner++$(runIO readProtocol >>= generateTypes)+$(runIO $ generateEnums <$> readProtocol)
+ Graphics/Wayland/Internal/SpliceServer.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE TemplateHaskell, ForeignFunctionInterface #-}++module Graphics.Wayland.Internal.SpliceServer where++import Data.Functor+import Language.Haskell.TH+import Foreign.C.Types++import Graphics.Wayland.Scanner.Protocol+import Graphics.Wayland.Scanner+import Graphics.Wayland.Internal.SpliceServerInternal+import Graphics.Wayland.Internal.SpliceServerTypes+++$(runIO readProtocol >>= generateServerExternalMethods)+$(runIO readProtocol >>= generateServerExternalListeners)
+ Graphics/Wayland/Internal/SpliceServerInternal.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE TemplateHaskell, ForeignFunctionInterface #-}++module Graphics.Wayland.Internal.SpliceServerInternal where++import Data.Functor+import Language.Haskell.TH+import Foreign.C.Types++import Graphics.Wayland.Scanner.Protocol+import Graphics.Wayland.Scanner+import Graphics.Wayland.Internal.SpliceServerTypes+import Graphics.Wayland.Internal.Util+++$(runIO readProtocol >>= generateServerInternalMethods)+$(runIO readProtocol >>= generateServerInternalListeners)
+ Graphics/Wayland/Internal/SpliceServerTypes.hs view
@@ -0,0 +1,13 @@+{-# LANGUAGE TemplateHaskell, ForeignFunctionInterface #-}++module Graphics.Wayland.Internal.SpliceServerTypes where++import Data.Functor+import Language.Haskell.TH+import Foreign.C.Types++import Graphics.Wayland.Scanner.Protocol+import Graphics.Wayland.Scanner++$(runIO readProtocol >>= generateTypes)+$(runIO $ generateEnums <$> readProtocol)
+ Graphics/Wayland/Internal/Util.chs view
@@ -0,0 +1,56 @@+{-# LANGUAGE DeriveDataTypeable #-}+module Graphics.Wayland.Internal.Util (+  CInterface(..), Client(..),++  Fixed256, Precision256,++  Time, millisecondsToTime, timeToMilliseconds, diffTimeToTime, timeToDiffTime+  ) where++import Data.Ratio ((%))+import Data.Time.Clock (DiffTime)+import Data.Fixed (Fixed(..), HasResolution(..), Milli(..))+import Data.Typeable+import Data.Functor+import Foreign+import Foreign.C.Types+import Foreign.C.String++#include <wayland-server.h>+#include <wayland-util.h>++{#context prefix="wl"#}+++-- | struct wl_interface pointer+{#pointer * interface as CInterface newtype#}++++-- | opaque server-side wl_client struct+newtype Client = Client (Ptr Client) deriving (Eq)++-- | 8 bits of precision means a resolution of 256.+data Precision256 = Precision256 deriving (Typeable)+instance HasResolution Precision256 where+  resolution _ = 256+-- | Fixed point number with 8 bits of decimal precision.+--+--   The equivalent of wayland's wl_fixed_t.+type Fixed256 = Fixed Precision256++-- | Represents time in seconds with millisecond precision.+--+--+type Time = Milli++millisecondsToTime :: CUInt -> Time+millisecondsToTime = MkFixed . fromIntegral+timeToMilliseconds :: Time -> CUInt+timeToMilliseconds (MkFixed n) = fromIntegral n++timeToDiffTime :: Time -> DiffTime+timeToDiffTime (MkFixed n) = fromRational (n % 1000)++diffTimeToTime :: DiffTime -> Time+diffTimeToTime = fromRational . toRational
+ Graphics/Wayland/Internal/Version.chs view
@@ -0,0 +1,7 @@+module Graphics.Wayland.Internal.Version (version) where++#include <wayland-version.h>++{#enum define VersionInt {WAYLAND_VERSION_MAJOR as MajorInt, WAYLAND_VERSION_MINOR as MinorInt, WAYLAND_VERSION_MICRO as MicroInt} deriving (Eq, Ord) #}++version = (fromEnum MajorInt, fromEnum MinorInt, fromEnum MicroInt)
+ Graphics/Wayland/Scanner.chs view
@@ -0,0 +1,445 @@+{-# LANGUAGE TemplateHaskell #-}++module Graphics.Wayland.Scanner (+  generateTypes, generateEnums, generateMethods, generateListeners,+  generateRegistryBind,++  generateRegistryBindInternal,+  generateRegistryBindExternal,++  generateClientInternalListeners,+  generateServerInternalListeners,++  generateClientExternalListeners,+  generateServerExternalListeners,++  generateClientInternalMethods,+  generateServerInternalMethods,++  generateClientExternalMethods,+  generateServerExternalMethods,++  module Graphics.Wayland.Scanner.Types,+  module Graphics.Wayland.Scanner.Protocol,++  CInterface(..)++  ) where++import Data.Functor ((<$>))+import Data.Either (lefts, rights)+import Data.Maybe (fromJust)+import Data.List (findIndex)+import Control.Monad (liftM)+import Foreign+import Foreign.C.Types+import Foreign.C.String (withCString)+import Language.Haskell.TH+import Language.Haskell.TH.Syntax (VarStrictType)++import Graphics.Wayland+import Graphics.Wayland.Scanner.Marshaller+import Graphics.Wayland.Scanner.Names+import Graphics.Wayland.Scanner.Protocol+import Graphics.Wayland.Scanner.Types+import Graphics.Wayland.Internal.Util hiding (Client)+import Graphics.Wayland.Internal.Util as Util (Client)+++-- Dear future maintainer,+-- I'm sorry.+++#include <wayland-server.h>++generateTypes :: ProtocolSpec -> Q [Dec]+generateTypes ps = liftM concat $ sequence $ map generateInterface (protocolInterfaces ps) where+  generateInterface :: Interface -> Q [Dec]+  generateInterface iface = do+    let iname = interfaceName iface+        pname = protocolName ps+        qname = interfaceTypeName pname iname+    constructorType <- [t|$(conT ''Ptr) $(conT qname)|]+    typeDec <- newtypeD (return []) qname [] (normalC qname [return (NotStrict, constructorType)]) [mkName "Show", mkName "Eq"]++    -- We will later need a pointer to the wl_interface structs, for passing to wl_proxy_marshal_constructor and wl_resource_create.+    -- Now, a pretty solution would construct its own wl_interface struct here.+    -- But that's way too much work for me. We just bind to the one generated by the C scanner.+    cInterfaceDec <- forImpD cCall unsafe ("&"++iname ++ "_interface") (interfaceCInterfaceName pname iname ) [t| (CInterface)|] -- pointer is fixed+    return $ typeDec : cInterfaceDec : []++generateRegistryBind :: ProtocolSpec -> Q [Either Dec Dec]+generateRegistryBind ps = do+  let messageCreatesIface child msg = any (\ argument ->+        case argument of+          (_, NewIdArg _ x, _) -> x == interfaceName child+          _                                        -> False)+        (messageArguments msg)+      interfaceCreatesIface child parent = any (messageCreatesIface child) (interfaceRequests parent)+      protocolCreatesIface child = any (interfaceCreatesIface child) (protocolInterfaces ps)+      globalInterfaces = filter (not.protocolCreatesIface) $ filter (\iface -> interfaceName iface /= "wl_display") (protocolInterfaces ps)++  -- static inline void * wl_registry_bind(struct wl_registry *wl_registry, uint32_t name, const struct wl_interface *interface, uint32_t version)+  -- id = wl_proxy_marshal_constructor((struct wl_proxy *) wl_registry, WL_REGISTRY_BIND, interface, name, interface->name, version, NULL);+  -- struct wl_proxy * wl_proxy_marshal_constructor(struct wl_proxy *proxy, uint32_t opcode, const struct wl_interface *interface, ...)+  liftM concat $ sequence $ map registryBindInterface globalInterfaces+    where+      registryBindInterface :: Interface -> Q [Either Dec Dec]+      registryBindInterface iface = do+        let iname = interfaceName iface+            pname = protocolName ps+            internalCName = mkName $ "wl_registry_" ++ iname ++ "_c_bind"+            exposeName = registryBindName pname iname++        fore <- forImpD cCall unsafe "wl_proxy_marshal_constructor" internalCName [t|$(conT $ mkName "Registry") -> {#type uint32_t#} -> CInterface -> CUInt -> Ptr CChar -> CUInt -> Ptr () -> IO $(conT $ interfaceTypeName pname iname) |]+        exposureDec <- [d|$(varP exposeName) = \ reg name strname version -> withCString strname $ \cstr -> $(varE internalCName) reg 0 $(varE $ interfaceCInterfaceName pname iname) (fromIntegral (name::Word)) cstr (fromIntegral (version::Word)) nullPtr |]+        return $ Left fore : map Right exposureDec++generateEnums :: ProtocolSpec -> [Dec]+generateEnums ps = concat $ map eachGenerateEnums (protocolInterfaces ps) where+  eachGenerateEnums :: Interface -> [Dec]+  eachGenerateEnums iface = concat $ map generateEnum $ interfaceEnums iface where+    generateEnum :: WLEnum -> [Dec]+    generateEnum wlenum =+      let qname = enumTypeName (protocolName ps) (interfaceName iface) (enumName wlenum)+      in+        NewtypeD [] qname [] (NormalC qname [(NotStrict, (ConT ''Int))]) [mkName "Show", mkName "Eq"]+        :+        map (\(entry, val) -> (ValD (VarP $ enumEntryHaskName (protocolName ps) (interfaceName iface) (enumName wlenum) entry) (NormalB $ (ConE qname) `AppE` (LitE $ IntegerL $ toInteger val)) [])) (enumEntries wlenum)++-- | generate FFI for a certain side of the API+--+--   Either Dec Dec explained: Left dec for internal declarations, Right dec for external declarations (ie. those that should be exposed to the user)+generateMethods :: ProtocolSpec -> ServerClient -> Q [Either Dec Dec]+generateMethods ps sc = liftM concat $ sequence $ map generateInterface $ filter (\iface -> if sc == Server then interfaceName iface /= "wl_display" else True) $ protocolInterfaces ps where+  generateInterface :: Interface -> Q [Either Dec Dec]+  generateInterface iface = do+    -- bind object destroyers+    let destroyName = mkName $ interfaceName iface ++ "_destructor"+    foreignDestructor <- forImpD cCall unsafe "wl_proxy_destroy" destroyName [t|$(conT $ interfaceTypeName (protocolName ps) (interfaceName iface)) -> IO ()|]+++    -- Okay, we have to figure out some stuff. There is a tree of possibilities:+    -- - Server+    --   => this is actually an easy case. every message is just some call to wl_resource_post_event+    -- - Client+    -- - - if a message has more than one new_id argument, skip (or undefined for safety?)+    -- - - 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+    -- - - if a message has a single typed new_id argument, then this is the return value of wl_proxy_marshal_constructor+    --     => pass a bunch of constants in the initial arguments. pass NULL in its argument position+    -- - - if a message has no new_id arguments, we are calling wl_proxy_marshal+    --   => for each argument EXCEPT new_id's(where we would pass NULL as discussed), pass that argument+    -- 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.+    --+    -- Further, in the Client case, we have to make a destructor. Some messages can have type="destructor" in the XML protocol files.+    -- - there is no message typed destructor with name "destroy"+    -- - - if the interface is wl_display, don't do anything+    -- - - if the interface is NOT wl_display+    --     => generate a new function "destroy", a synonnym for wl_proxy_destroy+    -- - otherwise, for each message typed destructor (possibly including "destroy")+    --   => call wl_proxy_marshal as normal, and *also* wl_proxy_destroy on this proxy (sole argument)+    -- - 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.+    --   the C scanner allows you to have a non-destructor "destroy", but I doubt that's the intention, so I'll make that undefined.+    -- "dirty" name of internal raw binding to C function++    let needsDefaultDestructor = ((sc == Client) && (not $ any messageIsDestructor $ interfaceRequests iface) && (interfaceName iface /= "wl_display"))+    defaultDestructor <- [d|$(varP $ requestHaskName (protocolName ps) (interfaceName iface) "destroy") = \ proxy -> $(varE destroyName) proxy|]++    let+     generateMessage :: Int -> Message -> Q [Either Dec Dec]+     generateMessage idx msg = -- list idx used for wl_proxy_marshal arguments+       let pname = protocolName ps+           iname = interfaceName iface+           mname = messageName msg++           hname = case sc of+                     Server -> eventHaskName pname iname mname+                     Client -> requestHaskName pname iname mname+           internalCName = case sc of+                             Server -> mkName $ "wl_rpe_" ++ interfaceName iface ++ "_" ++ messageName msg+                             Client -> mkName $ "wl_pm_" ++ interfaceName iface ++ "_" ++ messageName msg++       in case sc of+            Server -> do+              -- void wl_resource_post_event(struct wl_resource *resource, uint32_t opcode, ...);+              cdec <- forImpD cCall unsafe "wl_resource_post_event" internalCName [t|$(conT $ interfaceTypeName (protocolName ps) (interfaceName iface)) -> {#type uint32_t#} -> $(genMessageCType Nothing (messageArguments msg)) |]+              resourceName <- newName "resourceInternalName___"+              let messageIndexApplied = applyAtPosition (varE internalCName) (litE $ IntegerL $ fromIntegral idx) 1+                  resourceApplied = [e|$messageIndexApplied $(varE resourceName)|]+                  (pats,fun) = argTypeMarshaller (messageArguments msg) resourceApplied+              declist <- [d|$(varP hname) = $(LamE (VarP resourceName : pats) <$> fun)|]+              return (Left cdec:map Right declist)+            Client -> do+              let numNewIds = sum $ map (boolToInt . isNewId) $ messageArguments msg+                  argsWithoutNewId = filter (\arg -> not $ isNewId arg) (messageArguments msg)+                  returnArgument = head $ filter (\arg -> isNewId arg) (messageArguments msg)+                  returnName = let (_, NewIdArg _ theName, _) = returnArgument+                               in theName+                  returnType = [t|IO $(argTypeToCType returnArgument)|]+              cdec <- case numNewIds of+                        -- void wl_proxy_marshal(struct wl_proxy *proxy, uint32_t opcode, ...)+                        0 -> forImpD cCall unsafe "wl_proxy_marshal" internalCName [t|$(conT $ interfaceTypeName (protocolName ps) (interfaceName iface)) -> {#type uint32_t#} -> $(genMessageCType Nothing (messageArguments msg)) |]+                        -- struct wl_proxy * wl_proxy_marshal_constructor(struct wl_proxy *proxy, uint32_t opcode, const struct wl_interface *interface, ...)+                        1 -> forImpD cCall unsafe "wl_proxy_marshal_constructor" internalCName [t|$(conT $ interfaceTypeName (protocolName ps) (interfaceName iface)) -> {#type uint32_t#} -> CInterface -> $(genMessageCType (Just returnType) (messageArguments msg)) |]+++              proxyName <- newName "proxyInternalName___"+              let messageIndexApplied = applyAtPosition (varE internalCName) (litE $ IntegerL $ fromIntegral idx) 1+                  constructorApplied = case numNewIds of+                                         0 -> messageIndexApplied+                                         1 -> applyAtPosition messageIndexApplied (varE $ interfaceCInterfaceName pname (returnName)) 1+                  proxyApplied = [e|$constructorApplied $(varE proxyName)|]+                  makeArgumentNullPtr =+                      let argIdx = fromJust $ findIndex isNewId (messageArguments msg)+                          arg' = (messageArguments msg) !! argIdx+                          msgName = let (_,NewIdArg itsname _,_) = arg'+                                    in itsname+                      in [e|$(conE msgName) nullPtr|]+                  newIdNullInserted = case numNewIds of+                                        0 -> proxyApplied+                                        1 -> applyAtPosition proxyApplied makeArgumentNullPtr (fromJust $ findIndex isNewId (messageArguments msg))+                  finalCall = newIdNullInserted+                  (pats, fun) = argTypeMarshaller (argsWithoutNewId) finalCall+              declist <- [d|$(varP hname) = $(LamE (VarP proxyName : pats) <$> [e|do+                             -- Let's start by either calling wl_proxy_marshal or wl_proxy_marshal_constructor+                             retval <- $fun++                             -- possibly do some destruction here?+                             $(case messageIsDestructor msg of+                                 False -> [e|return retval|] -- do nothing (will hopefully get optimized away)+                                 True -> [e|$(varE destroyName) $(varE proxyName) |]+                                 )++                             return retval+                             |])|]++              return (Left cdec : map Right declist)++++    -- bind individual messages+    theMessages <- liftM concat $ sequence $ zipWith generateMessage [0..] $+        case sc of+                    Server -> interfaceEvents iface+                    Client -> interfaceRequests iface++    return $ Left foreignDestructor : theMessages ++ if needsDefaultDestructor then map Right defaultDestructor else []+++applyAtPosition :: ExpQ -> ExpQ -> Int -> ExpQ+applyAtPosition fun arg pos = do+  vars <- sequence $ map (\ _ -> newName "somesecretnameyoushouldntmesswith___") [0..(pos-1)]+  lamE (map varP vars) $+    appsE $ fun : (map varE vars) ++ [arg]++preComposeAt :: ExpQ -> ExpQ -> Int -> Int -> ExpQ+preComposeAt fun arg pos numArgs+  | pos > numArgs  = error "programming error"+preComposeAt fun arg pos numArgs = do+  vars <- sequence $ map (\ _ -> newName "yetanothernewvariablepleasedonttouchme___") [0..numArgs]+  lamE (map varP vars) $+    [e|do+      preCompVal <- $arg $(varE $ vars !! pos)+      $(appsE $ fun : (map varE $ take pos vars) ++ varE 'preCompVal : (map varE $ drop (pos+1) vars))+    |]++generateListeners :: ProtocolSpec -> ServerClient -> Q [Either Dec Dec]+generateListeners sp sc = do+  let pname = protocolName sp++  interfaces <- liftM concat $ sequence $ map (\iface -> generateListener sp iface sc) $+    filter (\iface -> 0 < (length $ case sc of+                                      Server -> interfaceRequests iface+                                      Client -> interfaceEvents iface)) $ protocolInterfaces sp+  resourceCreators <-+    case sc of+      Client -> return [] -- resources are created Server-side, and Client's proxies are created by the wayland library always+      Server -> liftM concat $ sequence $+        map (\ iface -> do+          let iname = interfaceName iface+              internalCName = mkName $ pname ++ "_" ++ iname ++ "_c_resource_create"+          foreignDec <- forImpD cCall unsafe "wl_resource_create" internalCName [t|Util.Client -> CInterface -> CInt -> {#type uint32_t#} -> IO $(conT $ interfaceTypeName pname iname) |]+          neatDec <- [d|$(varP $ interfaceResourceCreator pname iname) = \ client id ->+                          $(varE internalCName) client $(varE $ interfaceCInterfaceName pname iname) $(litE $ IntegerL $ fromIntegral $ interfaceVersion iface) id|]+          return $ Left foreignDec : map Left neatDec+          ) (protocolInterfaces sp)+  return $ interfaces ++ resourceCreators+++-- | generate FFI for the API that enables you to receive messages+--+--   Either Dec Dec explained: Left dec for internal declarations, Right dec for external declarations (ie. those that should be exposed to the user)+generateListener :: ProtocolSpec -> Interface -> ServerClient -> Q [Either Dec Dec]+generateListener sp iface sc =+  -- Tree of possibilities:+  -- - Server+  --   => call it an Implementation or Interface. first argument is the client, second is the resource+  -- - Client+  --   => call it a Listener. first argument is the proxy+  --+  -- for each argument (we're not gonna deal with untyped objects or new_ids):+  -- - typed new_id+  --   - Client+  --     => that type as arg+  --   - Server+  --     => 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.)+  -- - anything else+  --   => the type you'd expect+  let -- declare a Listener or Interface type for this interface+      typeName :: Name+      typeName = messageListenerTypeName sc (protocolName sp) (interfaceName iface)+      pname = protocolName sp+      iname :: String+      iname = interfaceName iface+      messages :: [Message]+      messages = case sc of+                   Server -> interfaceRequests iface+                   Client -> interfaceEvents iface+      mkMessageName :: Message -> Name+      mkMessageName msg = case sc of+                       Server -> requestHaskName pname iname (messageName msg)+                       Client -> eventHaskName pname iname (messageName msg)+      mkListenerType :: Message -> TypeQ+      mkListenerType msg = case sc of+                Server -> [t|Util.Client -> $(conT $ interfaceTypeName pname iname) -> $(genMessageHaskType Nothing $ messageArguments msg)|]  -- see large comment above+                Client -> [t|$(conT $ interfaceTypeName pname iname) -> $(genMessageHaskType Nothing $ messageArguments msg)|]+      mkListenerConstr :: Message -> VarStrictTypeQ+      mkListenerConstr msg = do+        let name = mkMessageName msg+        ltype <- mkListenerType msg+        return (name, NotStrict, ltype)+      listenerType :: DecQ+      listenerType = do+        recArgs <- sequence $ map mkListenerConstr messages+        return $ DataD [] typeName [] [RecC typeName recArgs] []++      -- in the weird uint32_t new_id case, first pass the id through wl_resource_create to just get a resource+      preCompResourceCreate clientName msg fun =+        case sc of+          Client -> fun+          Server -> foldr (\(arg, idx) curFunc ->+            case arg of+              (_, NewIdArg _ itsName, _) -> preComposeAt curFunc [e|$(varE $ interfaceResourceCreator pname itsName) $(varE clientName) |] idx (length $ messageArguments msg)+              _                          -> curFunc+            ) fun (zip (messageArguments msg) [1..])++      -- instance dec: this struct better be Storable+      instanceDec :: DecsQ+      instanceDec = do+        [d|instance Storable $(conT typeName) where+            sizeOf _ = $(litE $ IntegerL $ funcSize * (fromIntegral $ length messages))+            alignment _ = $(return $ LitE $ IntegerL funcAlign)+	    peek _ = undefined  -- we shouldn't need to be able to read listeners (since we can't change them anyway)+	    poke ptr record = $(doE $ ( zipWith (\ idx msg ->+                noBindS [e|do+                  let haskFun = $(return $ VarE $ mkMessageName msg) record+                      unmarshaller fun = \x -> $(let (pats, funexp) = argTypeUnmarshaller (messageArguments msg) ([e|fun x|])+                                                 in LamE pats <$> funexp)++                  funptr <- $(case sc of -- the Server-side listeners take an extra Client argument+                                Server -> [e|$(varE $ wrapperName msg) $ \ client -> ($(preCompResourceCreate 'client msg [e|unmarshaller $ haskFun client|])) |]+                                -- the Client-side listener takes a void* user_data argument, which we throw out cause it's not a sane api.+                                Client -> [e|$(varE $ wrapperName msg) $ \ _ -> unmarshaller haskFun|])++                  pokeByteOff ptr $(litE $ IntegerL (idx * funcSize)) funptr+                |] )+              [0..] messages+              ) ++ [noBindS [e|return () |]] )+            |]+++      -- FunPtr wrapper+      mkListenerCType msg = case sc of+                Server -> [t|Util.Client -> $(conT $ interfaceTypeName pname iname) -> $(genMessageWeirdCType Nothing $ messageArguments msg)|]  -- see large comment above+                Client -> [t|Ptr () -> $(conT $ interfaceTypeName pname iname) -> $(genMessageCType Nothing $ messageArguments msg)|]+      wrapperName msg = messageListenerWrapperName sc iname (messageName msg)+      wrapperDec msg = forImpD cCall unsafe "wrapper" (wrapperName msg) [t|$(mkListenerCType msg) -> IO (FunPtr ($(mkListenerCType msg))) |]++      -- bind add_listener+      haskName = requestHaskName pname iname "set_listener" -- dunno why I can't use this variable in the splice below.+      foreignName = requestInternalCName iname "c_add_listener"+      foreignDec :: Q Dec+      foreignDec = case sc of+                     -- void wl_resource_set_implementation(struct wl_resource *resource,+                     --    const void *implementation,+                     --    void *data,+                     --    wl_resource_destroy_func_t destroy);+                     -- typedef void (*wl_resource_destroy_func_t)(struct wl_resource *resource);+                     Server -> forImpD cCall unsafe "wl_resource_set_implementation" foreignName [t|$(conT $ interfaceTypeName pname iname) -> (Ptr $(conT $ typeName))  -> (Ptr ()) -> FunPtr ($(conT $ interfaceTypeName pname iname) -> IO ()) -> IO ()|]+                     -- int wl_proxy_add_listener(struct wl_proxy *proxy,+                     --    void (**implementation)(void), void *data);+                     Client -> forImpD cCall unsafe "wl_proxy_add_listener" foreignName [t|$(conT $ interfaceTypeName pname iname) -> (Ptr $(conT $ typeName))  -> (Ptr ()) -> IO CInt|]+      apiDec :: Q [Dec]+      apiDec = [d|$(varP $ requestHaskName (protocolName sp) iname "set_listener") = \ iface listener ->+                   do+                    -- malloc RAM for Listener type+                    memory <- malloc+                    -- store Listener type+                    poke memory listener+                    -- call foreign add_listener on stored Listener type+                    $(case sc of+                        Server -> [e|$(varE foreignName) iface memory nullPtr nullFunPtr|]+                        Client -> [e|errToResult <$> $(varE foreignName) iface memory nullPtr|])++                    |]++  in do+    -- Remember: Left for internal, Right for external.+    some <- sequence $ (liftM Right) listenerType : map (liftM Left . wrapperDec) messages+    other <- instanceDec+    more <- foreignDec+    last <- apiDec+    return $ some ++ (map Right other) ++ [Right more] ++ (map Right last)+++generateRegistryBindInternal sp = liftM lefts $ generateRegistryBind sp+generateRegistryBindExternal sp = liftM rights $ generateRegistryBind sp++generateClientInternalListeners sp = liftM lefts $ generateListeners sp Client+generateServerInternalListeners sp = liftM lefts $ generateListeners sp Server++generateClientExternalListeners sp = liftM rights $ generateListeners sp Client+generateServerExternalListeners sp = liftM rights $ generateListeners sp Server++generateClientInternalMethods :: ProtocolSpec -> Q [Dec]+generateClientInternalMethods ps = liftM lefts $ generateMethods ps Client++generateServerInternalMethods :: ProtocolSpec -> Q [Dec]+generateServerInternalMethods ps = liftM lefts $ generateMethods ps Server++generateClientExternalMethods :: ProtocolSpec -> Q [Dec]+generateClientExternalMethods ps = liftM rights $ generateMethods ps Client++generateServerExternalMethods :: ProtocolSpec -> Q [Dec]+generateServerExternalMethods ps = liftM rights $ generateMethods ps Server++genMessageCType :: Maybe TypeQ -> [Argument] -> TypeQ+genMessageCType = genMessageType argTypeToCType++genMessageWeirdCType :: Maybe TypeQ -> [Argument] -> TypeQ+genMessageWeirdCType = genMessageType argTypeToWeirdInterfaceCType++genMessageHaskType :: Maybe TypeQ -> [Argument] -> TypeQ+genMessageHaskType = genMessageType argTypeToHaskType++genMessageType :: (Argument -> TypeQ) -> Maybe TypeQ -> [Argument] -> TypeQ+genMessageType fun Nothing args =+  foldr (\addtype curtype -> [t|$(fun addtype) -> $curtype|]) [t|IO ()|] args+genMessageType fun (Just someType) args =+  foldr (\addtype curtype -> [t|$(fun addtype) -> $curtype|]) someType args++++-- | 3-tuple version of snd+snd3 :: (a,b,c) -> b+snd3 (_,b,_) = b++-- | Summable check if a given message argument is of type new_id+isNewId :: Argument -> Bool+isNewId arg = case arg of+                   (_, NewIdArg _ _, _) -> True+                   _                  -> False++boolToInt :: Bool -> Int+boolToInt True = 1+boolToInt False = 0
+ Graphics/Wayland/Scanner/Marshaller.chs view
@@ -0,0 +1,140 @@+{-# LANGUAGE TemplateHaskell, DeriveDataTypeable #-}+module Graphics.Wayland.Scanner.Marshaller (+  argTypeToCType, argTypeToHaskType, argTypeToWeirdInterfaceCType,++  argTypeMarshaller, argTypeUnmarshaller,++  funcSize, funcAlign+  ) where++import Data.Functor+import Data.Fixed (Fixed(..))+import Foreign+import Foreign.C.Types+import Foreign.C.String+import System.Process+import System.IO+import System.Posix.Types+import Language.Haskell.TH++import Graphics.Wayland.Internal.Util (Fixed256, Time, millisecondsToTime, timeToMilliseconds)+import Graphics.Wayland.Scanner.Protocol+import Graphics.Wayland.Scanner.Names+import Graphics.Wayland.Scanner.Types++#include <wayland-server.h>++{#context prefix="wl"#}+++wlFixedToFixed256 :: CInt -> Fixed256+wlFixedToFixed256 = MkFixed . fromIntegral+fixed256ToWlFixed :: Fixed256 -> CInt+fixed256ToWlFixed (MkFixed a) = fromIntegral a++argTypeToCType :: Argument -> TypeQ+argTypeToCType (_,IntArg,_) = [t| {#type int32_t#} |]+argTypeToCType (_,UIntArg,_) = [t| {#type uint32_t#} |]+argTypeToCType (_,FixedArg,_) = [t|{#type fixed_t#}|]+argTypeToCType (_,StringArg,_) = [t| Ptr CChar |]+argTypeToCType (_,(ObjectArg iname),_) = return $ ConT iname+argTypeToCType (_,(NewIdArg iname _),_) = return $ ConT iname+argTypeToCType (_,ArrayArg,_) = undefined+argTypeToCType (_,FdArg,_) = [t| {#type int32_t#} |]++argTypeToHaskType :: Argument -> TypeQ+argTypeToHaskType (_,IntArg,_) = [t|Int|]+argTypeToHaskType (name,UIntArg,_)+  | name == "time" = [t|Time|]+  | otherwise      = [t|Word|]+argTypeToHaskType (_,FixedArg,_) = [t|Fixed256|]+argTypeToHaskType (_,StringArg,False) = [t|String|]+argTypeToHaskType (_,(ObjectArg iname),False) = return $ ConT iname+argTypeToHaskType (_,(NewIdArg iname _),False) = return $ ConT iname+argTypeToHaskType (_,StringArg,True) = [t|Maybe String|]+argTypeToHaskType (_,(ObjectArg iname),True) = [t|Maybe $(conT iname) |]+argTypeToHaskType (_,(NewIdArg iname _),True) = [t|Maybe $(conT iname) |]+argTypeToHaskType (_,ArrayArg,_) = undefined+argTypeToHaskType (_,FdArg,_) = [t|Fd|]++argTypeToWeirdInterfaceCType :: Argument -> TypeQ+argTypeToWeirdInterfaceCType (_,(NewIdArg iname _),_) = [t|{#type uint32_t#}|]+argTypeToWeirdInterfaceCType x = argTypeToCType x++marshallerVar :: Argument -> Name+marshallerVar (name, _, _) = mkName name++-- | Allows a C function to receive Haskell data+argTypeMarshaller :: [Argument] -> ExpQ -> ([Pat], ExpQ)+argTypeMarshaller args fun =+  let vars = map marshallerVar args+      mk = return . VarE . marshallerVar+      applyMarshaller :: [Argument] -> ExpQ -> ExpQ+      applyMarshaller (arg@(_, IntArg, _):as) fun = [|$(applyMarshaller as [|$fun (fromIntegral ($(mk arg) :: Int) )|])|]+      applyMarshaller (arg@(name, UIntArg, _):as) fun+        | name == "time" = [|$(applyMarshaller as [|$fun (timeToMilliseconds ($(mk arg) :: Time))|]) |]+        | otherwise      = [|$(applyMarshaller as [|$fun (fromIntegral ($(mk arg) :: Word))|]) |]+      applyMarshaller (arg@(_, FixedArg, _):as) fun = [|$(applyMarshaller as [|$fun (fixed256ToWlFixed $(mk arg))|]) |]+      applyMarshaller (arg@(_, StringArg, False):as) fun = [|withCString $(mk arg) (\cstr -> $(applyMarshaller as [|$fun cstr|]))|]+      applyMarshaller (arg@(_, (ObjectArg iname), False):as) fun = [|$(applyMarshaller as [|$fun $(mk arg)|]) |]+      applyMarshaller (arg@(_, (NewIdArg iname _), False):as) fun = [|$(applyMarshaller as [|$fun $(mk arg) |])|]+      applyMarshaller (arg@(_, StringArg, True):as) fun = [|+           case $(mk arg) of+             Nothing  -> $(applyMarshaller as [|$fun nullPtr|])+             Just str -> withCString str (\cstr -> $(applyMarshaller as [|$fun cstr|]))+           |]+      applyMarshaller (arg@(_, (ObjectArg iname), True):as) fun = [|+           case $(mk arg) of+             Nothing  -> $(applyMarshaller as [|$fun ($(conE iname) nullPtr)|])+             Just obj -> $(applyMarshaller as [|$fun obj|])+           |]+      applyMarshaller (arg@(_, (NewIdArg iname _), True):as) fun = [|+           case $(mk arg) of+             Nothing  -> $(applyMarshaller as [|$fun ($(conE iname) nullPtr)|])+             Just obj -> $(applyMarshaller as [|$fun obj|])+           |]+      applyMarshaller (arg@(_, ArrayArg, _):as) fun = undefined+      applyMarshaller (arg@(_, FdArg, _):as) fun = [|$(applyMarshaller as [|$fun (unFd ($(mk arg)))|]) |]+      applyMarshaller [] fun = fun+  in  (map VarP vars, applyMarshaller args fun)++unFd (Fd k) = k++-- | Opposite of argTypeMarshaller: allows a Haskell function to receive C data.+argTypeUnmarshaller :: [Argument] -> ExpQ -> ([Pat], ExpQ)+argTypeUnmarshaller args fun =+  let vars = map marshallerVar args+      mk = return . VarE . marshallerVar+      applyUnmarshaller :: [Argument] -> ExpQ -> ExpQ+      applyUnmarshaller (arg@(_, IntArg, _):as) fun = [|$(applyUnmarshaller as [|$fun (fromIntegral ($(mk arg) :: CInt) )|])|]+      applyUnmarshaller (arg@(name, UIntArg, _):as) fun+        | name == "time" = [|$(applyUnmarshaller as [|$fun (millisecondsToTime ($(mk arg) :: CUInt))|]) |]+        | otherwise      = [|$(applyUnmarshaller as [|$fun (fromIntegral ($(mk arg) :: CUInt))|]) |]+      applyUnmarshaller (arg@(_, FixedArg, _):as) fun = [|$(applyUnmarshaller as [|$fun (wlFixedToFixed256 $(mk arg))|]) |]+      applyUnmarshaller (arg@(_, StringArg, False):as) fun = [|do str <- peekCString $(mk arg); $(applyUnmarshaller as [|$fun str|])|]+      applyUnmarshaller (arg@(_, (ObjectArg iname), False):as) fun = [|$(applyUnmarshaller as [|$fun $(mk arg)|]) |]+      applyUnmarshaller (arg@(_, (NewIdArg iname _), False):as) fun = [|$(applyUnmarshaller as [|$fun $(mk arg) |])|]+      applyUnmarshaller (arg@(_, StringArg, True):as) fun = [|do+               str <- if $(mk arg) == nullPtr+                         then return Nothing+                         else Just <$> peekCString $(mk arg)+               $(applyUnmarshaller as [|$fun str|])+               |]+      applyUnmarshaller (arg@(_, (ObjectArg iname), True):as) fun = [|$(applyUnmarshaller as [|$fun $+               let $(conP iname ([varP $ mkName "ptr___"])) = $(mk arg)+               in if $(varE $ mkName "ptr___") == nullPtr+                   then Nothing+                   else Just $(mk arg)|]) |]+      applyUnmarshaller (arg@(_, (NewIdArg iname _), True):as) fun = [|$(applyUnmarshaller as [|$fun $+               if $(mk arg) == nullPtr+                  then Nothing+                  else Just $ $(conE iname) $(mk arg)|]) |]+      applyUnmarshaller (arg@(_, ArrayArg, _):as) fun = undefined+      applyUnmarshaller (arg@(_, FdArg, _):as) fun = [|$(applyUnmarshaller as [|$fun (Fd ($(mk arg)))|]) |]+      applyUnmarshaller [] fun = fun+  in  (map VarP vars, applyUnmarshaller args fun)+++-- compute FunPtr size and alignment based on some dummy C type+funcSize = {#sizeof notify_func_t#} :: Integer+funcAlign = {#alignof notify_func_t#} :: Integer
+ Graphics/Wayland/Scanner/Names.hs view
@@ -0,0 +1,88 @@+module Graphics.Wayland.Scanner.Names (+  ServerClient(..),++  registryBindName,+  -- apparently we are not allowed to use foreign C names generated by the C scanner+  requestInternalCName, eventInternalCName,+  -- requestForeignCName, eventForeignCName,+  requestHaskName, eventHaskName,++  interfaceTypeName, interfaceCInterfaceName,+  enumTypeName, enumEntryHaskName,+  messageListenerTypeName,+  messageListenerWrapperName,+  interfaceResourceCreator,++  capitalize+  ) where++import Data.Char+import Data.List+import Language.Haskell.TH++import Graphics.Wayland.Scanner.Types+++registryBindName :: ProtocolName -> InterfaceName -> Name+registryBindName pname iname = mkName $ "registryBind" ++ (capitalize $ haskifyInterfaceName pname iname)++requestInternalCName :: InterfaceName -> MessageName -> Name+requestInternalCName iface msg = mkName $ iface ++ "_" ++ msg ++ "_request_binding"+eventInternalCName :: InterfaceName -> MessageName -> Name+eventInternalCName iface msg = mkName $ iface ++ "_" ++ msg ++ "_event_binding"++requestHaskName :: ProtocolName -> InterfaceName -> MessageName -> Name+requestHaskName pname iname mname = mkName $ toCamel (haskifyInterfaceName pname iname ++ "_" ++ mname)+eventHaskName :: ProtocolName -> InterfaceName -> MessageName -> Name+eventHaskName   pname iname mname = mkName $ toCamel (haskifyInterfaceName pname iname ++ "_" ++ mname)+enumEntryHaskName :: ProtocolName -> InterfaceName -> EnumName -> String -> Name+enumEntryHaskName pname iname ename entryName =+  mkName $ haskifyInterfaceName pname iname ++ capitalize (toCamel ename) ++ capitalize (toCamel entryName)++interfaceTypeName :: ProtocolName -> InterfaceName -> Name+interfaceTypeName pname iname = mkName $ capitalize $ haskifyInterfaceName pname iname++interfaceCInterfaceName :: ProtocolName -> InterfaceName -> Name+interfaceCInterfaceName _ iname = mkName $ iname ++ "_c_interface"++enumTypeName :: ProtocolName -> InterfaceName -> EnumName -> Name+enumTypeName pname iname ename = mkName $ capitalize $ haskifyInterfaceName pname iname ++ capitalize (toCamel ename)++messageListenerTypeName :: ServerClient -> ProtocolName -> InterfaceName -> Name+messageListenerTypeName Server pname iname = mkName $ capitalize (haskifyInterfaceName pname iname) ++ "Implementation"+messageListenerTypeName Client pname iname = mkName $ capitalize (haskifyInterfaceName pname iname) ++ "Listener"++messageListenerWrapperName :: ServerClient -> InterfaceName -> MessageName -> Name+messageListenerWrapperName Client iname mname = mkName $ iname ++ "_" ++ mname ++ "_listener_wrapper"+messageListenerWrapperName Server iname mname = mkName $ iname ++ "_" ++ mname ++ "_implementation_wrapper"++interfaceResourceCreator :: ProtocolName -> InterfaceName -> Name+interfaceResourceCreator pname iname = mkName $ pname ++ "_" ++ iname ++ "_resource_create"++-- | Some interfaces use a naming convention where wl_ or their protocol's name is prepended.+--   We remove both because it doesn't look very Haskelly.+haskifyInterfaceName :: ProtocolName -> InterfaceName -> String+haskifyInterfaceName pname iname =+  toCamel $ removeInitial (pname ++ "_") $ removeInitial "wl_" iname+++-- stupid utility functions follow++-- | if the second argument starts with the first argument, strip that start+removeInitial :: Eq a => [a] -> [a] -> [a]+removeInitial remove input = if remove `isPrefixOf` input+                                     then drop (length remove) input+                                     else input++-- | convert some_string to someString+toCamel :: String -> String+toCamel (a:'_':c:d) | isAlpha a, isAlpha c = a : toUpper c : toCamel d+toCamel (a:b) = a : toCamel b+toCamel x = x+++capitalize :: String -> String+capitalize x = toUpper (head x) : tail x++-- decapitalize :: String -> String+-- decapitalize x = toLower (head x) : tail x
+ Graphics/Wayland/Scanner/Protocol.hs view
@@ -0,0 +1,88 @@+module Graphics.Wayland.Scanner.Protocol (+  readProtocol, parseFile+  ) where++import Data.Functor+import Data.Maybe+import Data.Char+import Text.XML.Light+import System.Process++import Graphics.Wayland.Scanner.Types+import Graphics.Wayland.Scanner.Names++interface  = QName "interface"  Nothing Nothing+request    = QName "request"    Nothing Nothing+event      = QName "event"      Nothing Nothing+enum       = QName "enum"       Nothing Nothing+entry      = QName "entry"      Nothing Nothing+arg        = QName "arg"        Nothing Nothing+namexml    = QName "name"       Nothing Nothing+version    = QName "version"    Nothing Nothing+allow_null = QName "allow-null" Nothing Nothing+typexml    = QName "type"       Nothing Nothing+value      = QName "value"      Nothing Nothing++parseInterface :: ProtocolName -> Element -> Interface+parseInterface pname elt =+  let iname = fromJust $ findAttr namexml elt++      parseMessage :: Element -> Maybe Message+      parseMessage msgelt = do -- we're gonna do some fancy construction to skip messages we can't deal with yet+        let name = fromJust $ findAttr namexml msgelt+        arguments <- mapM parseArgument (findChildren arg msgelt)+        let destructorVal = findAttr typexml msgelt+        let isDestructor = case destructorVal of+                             Nothing -> False+                             Just str -> str=="destructor"++        return Message {messageName = name, messageArguments = arguments, messageIsDestructor = isDestructor} where+          parseArgument argelt = do+            let msgname = fromJust $ findAttr namexml argelt+            let argtypecode = fromJust $ findAttr typexml argelt+            argtype <- case argtypecode of+              "object" -> ObjectArg . interfaceTypeName pname <$> findAttr interface argelt+              "new_id" -> (\iname -> NewIdArg (interfaceTypeName pname iname) iname) <$> findAttr interface argelt+              _ -> lookup argtypecode argConversionTable+            let allowNull = fromMaybe False (read <$> capitalize <$> findAttr allow_null argelt)+            return (msgname, argtype, allowNull)++      parseEnum enumelt =+        let enumname = fromJust $ findAttr namexml enumelt+            entries = map parseEntry $ findChildren entry enumelt+        in WLEnum {enumName = enumname, enumEntries = entries} where+          parseEntry entryelt = (fromJust $ findAttr namexml entryelt,+                                 read $ fromJust $ findAttr value entryelt :: Int)+  in Interface {+     interfaceName = iname,+     interfaceVersion = read $ fromJust $ findAttr version elt, -- unused atm+     interfaceRequests = mapMaybe parseMessage (findChildren request elt),+     interfaceEvents = mapMaybe parseMessage (findChildren event elt),+     interfaceEnums = map parseEnum $ findChildren enum elt+     }++parseProtocol :: [Content] -> ProtocolSpec+parseProtocol xmlTree =+  let subTree = (!!1) $ onlyElems xmlTree -- cut off XML header stuff+      pname = fromJust $ findAttr namexml subTree+      interfaces = map (parseInterface pname) $ findChildren interface subTree+  in ProtocolSpec pname interfaces++parseFile :: FilePath -> IO ProtocolSpec+parseFile filename = do+  fileContents <- readFile filename+  return $ parseProtocol $ parseXML fileContents++-- | locate wayland.xml on disk and parse it+readProtocol :: IO ProtocolSpec+readProtocol = do+  datadir <- figureOutWaylandDataDir+  parseFile (datadir ++ "/" ++ protocolFile)+++-- TODO move this into some pretty Setup.hs thing as soon as someone complains about portability+figureOutWaylandDataDir :: IO String+figureOutWaylandDataDir =+  head <$> lines <$> readProcess "pkg-config" ["wayland-server", "--variable=pkgdatadir"] []++protocolFile = "wayland.xml"
+ Graphics/Wayland/Scanner/Types.hs view
@@ -0,0 +1,48 @@+module Graphics.Wayland.Scanner.Types where++import Language.Haskell.TH (Name)+++data ServerClient = Server | Client  deriving (Eq)++-- | wayland-style interface name (e.g. wl_display)+type InterfaceName = String+data Interface = Interface {+  interfaceName :: InterfaceName,+  interfaceVersion :: Int,+  interfaceRequests :: [Message], -- ^ aka requests+  interfaceEvents :: [Message],+  interfaceEnums :: [WLEnum]+  } deriving (Show)++type EnumName = String+-- | wayland style enum specification (not Prelude)+data WLEnum = WLEnum {+  enumName :: EnumName,+  enumEntries :: [(String,Int)]+  } deriving (Show)++-- | wayland wire protocol argument type. we can't deal with untyped object/new-id arguments.+data ArgumentType = IntArg | UIntArg | FixedArg | StringArg | ObjectArg Name | NewIdArg Name MessageName | ArrayArg | FdArg deriving (Show)+argConversionTable :: [(String, ArgumentType)] -- for all easy argument types+argConversionTable = [+  ("int", IntArg),+  ("uint", UIntArg),+  ("fixed", FixedArg),+  ("string", StringArg),+  ("fd", FdArg)]++type Argument = (String, ArgumentType, Bool) -- name, argument type, allow-null++type MessageName = String+data Message = Message {+  messageName :: MessageName,+  messageArguments :: [Argument],+  messageIsDestructor :: Bool+  } deriving (Show)++type ProtocolName = String+data ProtocolSpec = ProtocolSpec {+  protocolName :: ProtocolName,+  protocolInterfaces :: [Interface]+  } deriving (Show)
+ Graphics/Wayland/Server.hs view
@@ -0,0 +1,11 @@+module Graphics.Wayland.Server (+  module Graphics.Wayland.Internal.Server,  -- this will need to be removed when the lib is at a more complete state+  module Graphics.Wayland.Internal.SpliceServer,+  module Graphics.Wayland.Internal.SpliceServerTypes,+  Client(..)+  ) where++import Graphics.Wayland.Internal.Server+import Graphics.Wayland.Internal.SpliceServer+import Graphics.Wayland.Internal.SpliceServerTypes+import Graphics.Wayland.Internal.Util
+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2014 Auke Booij++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ NOTES.md view
@@ -0,0 +1,201 @@+Overview+===+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.+Additionally, wayland can help creating shared memory buffers to exchange bulk data (ie. screen drawings).++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).+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).++Other documentation:++- [Official wayland docs](http://wayland.freedesktop.org/docs/html/)+- [Pekka Paalanen's object lifespan blog post](http://ppaalanen.blogspot.com/2014/07/wayland-protocol-design-object-lifespan.html)+- [Jason Ekstrand's wayland language bindings guide](http://www.jlekstrand.net/jason/projects/wayland/language-bindings-guide/)++Terminology+===+- Event: something that's sent from the server to the client+- Request: something that's sent from the client to the server+- Message: either an event or a request. Always associated to an object (so either a proxy or a resource)+- 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.+- 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)+- 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.+- Proxy: the client-side representation of a wayland object+- 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")+- Implementation: the server-side callback mechanism for receiving messages. In particular, a specific instance of callback specifications.+- Enum: a list of constants. Used to give semantics to integer message arguments. Sometimes actually an enumeration, sometimes a bitfield, sometimes neither.+- Argument: messages can have several bits of data associated with them, which are called arguments.+- 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)+- List: a wl\_list or a wl\_array+- 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+- 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.)+- 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)+- 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.+- 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.+- ...++From here on, "object" refers to a wayland object in the sense of wl\_proxy or wl\_resource.++Object creation+===+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).+But on the client side, the way you request objects is by sending the right request messages.+So that leaves us with a dependency problem: as a client, how do you request your first object?+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).++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.+The arguments to bind define the type of the return value, which is why we bind to it manually.+Additionally, it is only known at runtime which objects can be constructed using bind (because they are advertised as such by the "global" event).++The reason behind this is:++1. Different compositors implement different protocols, so having a connection does not guarantee that you can create the objects you want;+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.++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).++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.++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.++I haven't yet figured out what the server side does here exactly.+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.+Additionally, presumably to do a wl\_resource\_create, you will need some kind of wl\_proxy to bind it to.+IOW I *THINK* that servers are not free to construct wl\_resource instances as they please.++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.++Object destruction+===+The client and server can both destroy objects: the client using wl\_proxy\_destroy, and the server using wl\_resource\_destroy.+Additionally, some interfaces expose a "destroy" request, which, if available, must be used.++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.+Hence, utmost care should be taken when you wish to destroy an object from the server side.+Consider refactoring your protocol.++Receiving messages+===+Messages are received on both sides using callbacks.+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.+You specify these callbacks using the Listener stuff.+Note that you can only set listeners once for every proxy!++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).+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.++Sending messages+===+Every message has a list of arguments. Every argument has a name and a type. The following types are available:++- int, uint, fixed (integer, unsigned integer, float)+- object, new\_id+- array (which we don't bind to atm)+- fd (just an integer)++Most types speak for themselves, but the "object" and "new\_id" types need some discussion.++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.++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.++When a new\_id argument is present, the request instructs the server to create an object with a given identification.+Such creations are guaranteed to work as long as protocol is followed.+So this gives the client a handle to an object on the server.+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.++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).+The only known exception is wl\_registry.bind, which has a special purpose anyway, and we'll bind manually.++Various quotes from #wayland IRC+===++    <Jasper> Requests are from the client to the server. Events are from the server to the client.+++    <tulcod> 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+    <giucam> the magic interfaces are just wl_display and wl_registry+    <giucam> that's it+++    <tulcod> 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?+    <jekstrand> tulcod: I think so+    <jekstrand> 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)+    <tulcod> 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?+    <tulcod> whereas interfaces (aka implementations?) are just the server-side way to receive events from a client?+    <tulcod> ie the wl_signal and wl_listener stuff is intended to exchange events /within the server/, instead of between the server and client?+    <jekstrand> pretty much+    <jekstrand> libwayland may use signals internally for some things too (I don't remember)+    <jekstrand> but you can implement a wayland server without ever using one.+++    <tulcod> so if i want to bind to wayland, do i bind to wl_listener at all?+    <tulcod> would a minimal API include it?+    <jekstrand> tulcod: No, it's not needed.+    <jekstrand> You may find it useful, but you can get along without it just fine.+    <Jasper> It's a convenience to know when a resource is destroyed.+    <Jasper> If you are wrapping the library, you know when a resource is destroyed, because somebody called the destroy function.+++    <tulcod> "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."+    <tulcod> so what if i use wl_registry.bind to create a wl_surface?+    <giucam> 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+    <tulcod> oh, non sequitur, by the way+    <tulcod> giucam: but "Object creation never fails."+    <giucam> tulcod: i don't think that applies to globals+    <giucam> binding a global can fail, and the server will create a dummy wl_resource, send an error and destroy it+    <tulcod> ah, so it can fail, it's just that it tells you afterwards+    <tulcod> ie it tells you if it failed, or doesn't tell you anything if it succeeded+    <giucam> but i'm not sure what wl_registry.bind returns if it fails+    <giucam> i.e if it is a valid proxy, and what happens if you call a request on it+    <giucam> probably fails in a non-destructive way+++    <pq> tulcod, all requests always "succeed" - if they don't, you violated the protocol.+++    <pq> tulcod, did you already notice that there are at least three different wl_display structs?+    <pq> server-side wl_display (opaque), client-side wl_display (opaque), and the wl_proxy cast to wl_display IIRC+    <pq> the first member of client wl_display is a wl_proxy+    <pq> so it's interchangeable+++    <pq> tulcod, btw. another thing you should be wary with is wl_buffer.+    <pq> tulcod, again, the client-side wl_buffer is a wl_proxy. The server-side is the tricky one.+    <tulcod> pq: ah, but the server-side one is deprecated :)+++    <Cloudef> I wonder if wl_resource_destroy_func_t is needed for set_implementation calls which interface already contains destroy function+    <jekstrand> yes, they serve different purposes+    <jekstrand> The one on the interface lets you know that the client has sent the destroy request+    <jekstrand> 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.+    <tulcod> Cloudef: you mean "interfaces which have a 'destroy' request" ?+    <Cloudef> tulcod: yes+    <tulcod> ok yes, then i agree with jekstrand+    <Cloudef> jekstrand: on which function I should actually free the resource?+    <Cloudef> weston seems to do this on the interface one+    <Cloudef> (and on the other one too)+    <tulcod> (fwiw, it's no problem to free twice)+    <jekstrand> Cloudef: You need to call wl_resource_destroy in the interface one.  wl_resource_destroy calls th wl_resource_destroy_func_t one.+    <jekstrand> 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()+    <pq> 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.+    <jekstrand> the interface one is just a request, that's all.  there's no implicit destruction of resources.+    <pq> ..except on the client side, so the server side cannot really not do it, too+    <pq> since server and client must agree on what objects exist+    <jekstrand> yup+++    <pq> when we say that an object is a singleton, we usually mean the real object, not the protocol object+++    <tulcod> jekstrand: uhm, so let's suppose the client has a wl_shell_surface+    <tulcod> jekstrand: and the server, for whatever reason, destroys it+    <tulcod> what am i missing? can't the client keep the handle to that non-existent object?+    <jekstrand> the server can't just up and destroy it+    <jekstrand> that's a broken server.  Clients shouldn't handle that case.+    <tulcod> jekstrand: okay, so compositors can't freely destroy stuff?+    <jekstrand> nope+    <jekstrand> If compositors were allowed to add-hock destroy client's objects, that would result in insanity+++    <jekstrand> 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.
+ README.md view
@@ -0,0 +1,155 @@+# Haskell Wayland bindings #+Uh... these are what you'd expect.++> 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.++Refer to `NOTES.md` for more notes on wayland terminology, how it works, and ways to shoot yourself in the foot.+++## Quick example ##++> This paragraph is literate haskell.++    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).++    Let's start with some imports. We'll need to poll for a connection, so import Fd waiting tools.++    > import Control.Concurrent (threadWaitRead)++    We are going to write a Client-side program, so:++    > import Graphics.Wayland.Client++    > main = do++    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.++    >   connect <- displayConnect+    >   let display = case connect of+    >                   Just x -> x+    >                   Nothing -> error "couldn't connect to a wayland server"++    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.++    >   fd <- displayGetFd display+    >   putStrLn $ "Using file descriptor " ++ show fd+    >   putStrLn $ "Display at " ++ show display++    The "registry" is the entry point to get access to the server's useful objects.++    >   registry <- displayGetRegistry display+    >   putStrLn $ "Registry at "++ show registry++    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.+	It does so by sending an "event" (ie. a message from the server to the client) that it has.+	So let's go ahead and write code that can listen to such events.+	The registry offers two events:+	- a "global" event indicating that an object has become available for construction, and+	- a "global_remove" event indicating that an object is no longer constructible.++    >   let listener = RegistryListener {+    >     registryGlobal = \reg name ifacename version -> putStrLn $ "Received global " ++ show name ++ " (" ++ ifacename ++ ") version " ++ show version,+    >     registryGlobalRemove = \ _ _ -> return ()+    >     }++    Now we need to activate this listener.+	Client-side, you can only set a specific object's listener once, so this operation might fail if you already set one previously.++    >   errorCode <- registrySetListener registry listener+    >   putStrLn $ "Setting registry listener... " ++ show errorCode++	We are now ready to start receiving the "global" events.+	Before reading, we need to let wayland know we want to read - essentially meaning we lock (in the sense of mutex) the reading mechanism.++    >   res <- displayPrepareRead display+    >   putStrLn $ "Preparing read... " ++ show res++    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.+	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.+	But that means that the construction of the registry we did earlier might actually not have reached the server yet.+	So before we do anything else, we should flush the write buffer.++    >   flushed <- displayFlush display+    >   putStrLn $ "Flushed " ++ show flushed++    Now poll for the socket to have data available.++    >   putStrLn "polling"+    >   threadWaitRead fd+    >   putStrLn $ "Ready to read."++    We can now process the data that's waiting for us on the socket, and dispatch the event listeners.+	The latter will call e.g. our registryGlobal function with the incoming event's parameters.++    >   events <- displayReadEvents display+    >   putStrLn $ "Read display events: " ++ show events+    >   dispatched <- displayDispatchPending display+    >   putStrLn $ "Dispatched events: " ++ show dispatched++    All wayland objects we constructed are automatically destroyed when we disconnect.++    >   displayDisconnect display+++## API design and symbol naming ##++The majority of the Wayland API is based on an object-oriented event framework.+The objects have a type, which wayland calls an _interface_.+A _protocol_ defines a list of such interfaces.++Haskell renames these interfaces by, if possible, removing `wl_`, and, if possible, removing `<name of the protocol>_`, and then converting to CamelCase.+For example:++- `wl_display` is called `Display` in haskell-wayland+- `wl_registry` -> `Registry`+- `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)+- `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)+- ...++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`.+++## Splicing a different protocol XML file ##++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.+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`, ...).++The program that generates these protocol header files is called a _scanner_, and wayland ships with `wayland-scanner`.+For haskell-wayland, you can find the equivalent in `Graphics.Wayland.Scanner`.+Its purpose is to bind to the C wayland interface and marshall all values.++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` (but this might change to fix what symbols that are exposed to the user).+Only the first two are to be exported to the user (see `Graphics.Wayland.Client` and notice that `Graphics.Wayland.Internal.SpliceClientInternal` is absent).+(Ditto for the Server-side.)++## Value marshalling ##++Wherever possible, all C values are marshalled to Haskell equivalents.+For the protocol API, this is done by `Graphics.Wayland.Scanner.Marshall`, and for the fixed api manually (but that's mostly trivial).++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).+++## Technical notices ##++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).++Since Template Haskell doesn't yet support splicing the module statement, or otherwise dynamically specifying which symbols get exported, currently you can access some `_request_binding` functions and `_c_interface` values, e.g. `wl_data_offer_c_add_listener_request_binding` and `wl_keyboard_c_interface`. These should be internal, and one of these days I'll fix that.++In terms of safety, there are plenty of opportunities with this library to shoot yourself in the foot.+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.+++## Debugging ##++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.+++## TODO ##++- prettify binding to wl_registry.bind (ie make more type-safe, add haskell documentation, etc)+- fix exposed symbols+- some kind of fancy FRP library binding?+- write documentation strings from .protocol files into haddock???+- allow easy building of other .protocol files into haskell bindings+- protocol version checker function
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ hayland.cabal view
@@ -0,0 +1,91 @@+-- Initial haskell-wayland.cabal generated by cabal init.  For further+-- documentation, see http://haskell.org/cabal/users-guide/++name:                hayland+version:             0.1.0.0+synopsis:            Haskell bindings for the C Wayland library.+description:         This package contains bindings to the Wayland library, which is used to interface display devices, drawable clients, and window managers.+                     .+                     Wayland exposes a "fixed" set of functions, and additionally generates a part of its API from a "protocol" file.+                     This package locates that protocol file using pkg-config.+                     .+                     If you want to interface with other protocols (such as Weston's), refer to the readme for instructions.+license:             MIT+license-file:        LICENSE+author:              Auke Booij+maintainer:          auke@tulcod.com+-- copyright:+category:            Graphics+build-type:          Custom+extra-source-files:  README.md, NOTES.md+cabal-version:       >=1.10++source-repository head+  type:     git+  location: https://github.com/tulcod/haskell-wayland++library+  exposed-modules:+    Graphics.Wayland,+    Graphics.Wayland.Client,+    Graphics.Wayland.Server,+    Graphics.Wayland.Scanner+  other-modules:+    Graphics.Wayland.Internal,+    Graphics.Wayland.Internal.Client,+    Graphics.Wayland.Internal.Cursor,+    Graphics.Wayland.Internal.EGL,+    Graphics.Wayland.Internal.ServerClientState,+    Graphics.Wayland.Internal.Server,+    Graphics.Wayland.Internal.Util,+    Graphics.Wayland.Internal.Version,+    Graphics.Wayland.Internal.SpliceClient,+    Graphics.Wayland.Internal.SpliceServer,+    Graphics.Wayland.Internal.SpliceClientTypes,+    Graphics.Wayland.Internal.SpliceServerTypes,+    Graphics.Wayland.Internal.SpliceClientInternal,+    Graphics.Wayland.Internal.SpliceServerInternal,+    Graphics.Wayland.Scanner.Marshaller,+    Graphics.Wayland.Scanner.Names,+    Graphics.Wayland.Scanner.Protocol,+    Graphics.Wayland.Scanner.Types+  build-depends:       base >=4.7 && <4.8, xml >= 1.3 && < 1.4, process >= 1.1 && < 2, template-haskell > 2 && < 3, data-flags <0.1, time <1.5+  default-extensions:  ForeignFunctionInterface+  -- hs-source-dirs:+  default-language:    Haskell2010+  cc-options: -fPIC+  -- ghc-options: -ddump-splices+  extra-libraries:+    wayland-client,+    wayland-cursor,+    wayland-egl,+    wayland-server+  includes:+    wayland-client.h,+    wayland-server.h,+    wayland-client-protocol.h,+    wayland-server-protocol.h,+    wayland-util.h,+    wayland-version.h,+    wayland-egl.h++-- FIXME: this tests assumes there's a wayland server (e.g. weston) running.+test-suite firsttest+  hs-source-dirs: tests+  type: exitcode-stdio-1.0+  main-is: test.hs+  build-depends: base, hayland, xml, process+  default-language:    Haskell2010++test-suite enumtest+  hs-source-dirs: tests+  type: exitcode-stdio-1.0+  main-is: enums.hs+  build-depends: base, hayland, xml, process+  default-language:    Haskell2010++executable wayland-list-globals+  hs-source-dirs: tests+  main-is: listglobals.hs+  build-depends: base, hayland+  default-language: Haskell2010
+ tests/enums.hs view
@@ -0,0 +1,6 @@+import Graphics.Wayland.Client++a :: DisplayError+a = displayErrorInvalidMethod++main = print a
+ tests/listglobals.hs view
@@ -0,0 +1,33 @@+import Control.Concurrent++import Graphics.Wayland.Client++main = do+  connect <- displayConnect+  let display = case connect of+                  Just x -> x+                  Nothing -> error "couldn't connect to a wayland server."+  fd <- displayGetFd display+  putStrLn $ "Using file descriptor " ++ show fd+  putStrLn $ "Display at " ++ show display+  registry <- displayGetRegistry display+  putStrLn $ "Registry at "++ show registry+  let listener = RegistryListener {+    registryGlobal = \reg name ifacename version -> putStrLn $ "Received global " ++ show name ++ " (" ++ ifacename ++ ") version " ++ show version,+    registryGlobalRemove = \ _ _ -> return ()+    }+  errorCode <- registrySetListener registry listener+  putStrLn $ "Setting registry listener... " ++ show errorCode++  res <- displayPrepareRead display+  putStrLn $ "Preparing read... " ++ show res+  flushed <- displayFlush display+  putStrLn $ "Flushed " ++ show flushed+  putStrLn "polling"+  threadWaitRead fd+  putStrLn $ "Ready to read."+  events <- displayReadEvents display+  putStrLn $ "Read display events: " ++ show events+  dispatched <- displayDispatchPending display+  putStrLn $ "Dispatched events: " ++ show dispatched+  displayDisconnect display
+ tests/test.hs view
@@ -0,0 +1,19 @@+import Control.Concurrent++import Graphics.Wayland.Client++main = do+  connect <- displayConnect+  print connect+  let display = case connect of+                  Just x -> x+                  Nothing -> error "could not connect to a wayland server"+  b <- displaySync display+  print b+  let listener = CallbackListener {+    callbackDone = \ _ _ -> putStrLn "received done"+    }+  callbackSetListener b listener+  displayFlush display+  displayGetFd display >>= threadWaitRead+  displayDispatch display