diff --git a/bindings-wlc.cabal b/bindings-wlc.cabal --- a/bindings-wlc.cabal +++ b/bindings-wlc.cabal @@ -1,5 +1,5 @@ name: bindings-wlc -version: 0.1.0.0 +version: 0.1.0.1 synopsis: Bindings against the wlc library description: Please see README.md homepage: http://github.com/aktowns/bindings-wlc#readme @@ -19,11 +19,15 @@ Bindings.WLC Bindings.WLC.Defines Bindings.WLC.Geometry - Bindings.WLC.WLC - Bindings.WLC.WLCRender - Bindings.WLC.WLCWayland + Bindings.WLC.Core + Bindings.WLC.Render + Bindings.WLC.Wayland + System.WLC + System.WLC.Geometry + System.WLC.Core build-depends: base >= 4.7 && < 5, - bindings-DSL >= 1.0.23 && < 1.1 + bindings-DSL >= 1.0.23 && < 1.1, + convertible >= 1.1.1.0 && < 1.1.2.0 default-language: Haskell2010 extra-libraries: wlc default-extensions: diff --git a/src/Bindings/WLC.hs b/src/Bindings/WLC.hs --- a/src/Bindings/WLC.hs +++ b/src/Bindings/WLC.hs @@ -1,3 +1,7 @@ module Bindings.WLC where -import Bindings.WLC.WLC +import Bindings.WLC.Defines +import Bindings.WLC.Geometry +import Bindings.WLC.Core +import Bindings.WLC.Render +import Bindings.WLC.Wayland diff --git a/src/Bindings/WLC/Core.hsc b/src/Bindings/WLC/Core.hsc new file mode 100644 --- /dev/null +++ b/src/Bindings/WLC/Core.hsc @@ -0,0 +1,324 @@ +#include +#include + +{-| +Module : Bindings.WLC.WLC +Description : Core WLC +Copyright : (c) Ashley Towns 2016 +License : BSD3 +Maintainer : mail@ashleytowns.id.au +Stability : experimental +Portability : POSIX + +Provides bindings to the core WLC API. +-} +module Bindings.WLC.Core where +#strict_import + +import Bindings.WLC.Defines +import Bindings.WLC.Geometry + +#opaque_t wlc_event_source +#opaque_t xkb_state +#opaque_t xkb_keymap +#opaque_t libinput_device + +-- |wlc_log(), wlc_vlog(); +#integral_t enum wlc_log_type +#num WLC_LOG_INFO +#num WLC_LOG_WARN +#num WLC_LOG_ERROR +#num WLC_LOG_WAYLAND + +-- |wlc_get_backend_type(); +#integral_t enum wlc_backend_type +#num WLC_BACKEND_NONE +#num WLC_BACKEND_DRM +#num WLC_BACKEND_X11 + +-- |mask in wlc_event_loop_add_fd(); +#integral_t enum wlc_event_bit +#num WLC_EVENT_READABLE +#num WLC_EVENT_WRITABLE +#num WLC_EVENT_HANGUP +#num WLC_EVENT_ERROR + +-- |wlc_view_get_state(); +#integral_t enum wlc_view_state_bit +#num WLC_BIT_MAXIMIZED +#num WLC_BIT_FULLSCREEN +#num WLC_BIT_RESIZING +#num WLC_BIT_MOVING +#num WLC_BIT_ACTIVATED + +-- |wlc_view_get_type(); +#integral_t enum wlc_view_type_bit +-- |Override redirect (x11) +#num WLC_BIT_OVERRIDE_REDIRECT +-- |Tooltips, DnD's, menus (x11) +#num WLC_BIT_UNMANAGED +-- |Splash screens (x11) +#num WLC_BIT_SPLASH +-- |Modal windows (x11) +#num WLC_BIT_MODAL +-- |xdg-shell, wl-shell popups +#num WLC_BIT_POPUP + +-- |wlc_view_set_geometry(); Edges in interface interface.view.request.resize function. +#integral_t enum wlc_resize_edge +#num WLC_RESIZE_EDGE_NONE +#num WLC_RESIZE_EDGE_TOP +#num WLC_RESIZE_EDGE_BOTTOM +#num WLC_RESIZE_EDGE_LEFT +#num WLC_RESIZE_EDGE_TOP_LEFT +#num WLC_RESIZE_EDGE_BOTTOM_LEFT +#num WLC_RESIZE_EDGE_RIGHT +#num WLC_RESIZE_EDGE_TOP_RIGHT +#num WLC_RESIZE_EDGE_BOTTOM_RIGHT + +-- |Mods in interface.keyboard.key function. +#integral_t enum wlc_modifier_bit +#num WLC_BIT_MOD_SHIFT +#num WLC_BIT_MOD_CAPS +#num WLC_BIT_MOD_CTRL +#num WLC_BIT_MOD_ALT +#num WLC_BIT_MOD_MOD2 +#num WLC_BIT_MOD_MOD3 +#num WLC_BIT_MOD_LOGO +#num WLC_BIT_MOD_MOD5 + +-- |Leds in interface.keyboard.key function. +#integral_t enum wlc_led_bit +#num WLC_BIT_LED_NUM +#num WLC_BIT_LED_CAPS +#num WLC_BIT_LED_SCROLL + +-- |State in interface.keyboard.key function. +#integral_t enum wlc_key_state +#num WLC_KEY_STATE_RELEASED +#num WLC_KEY_STATE_PRESSED + +-- |State in interface.pointer.button function. +#integral_t enum wlc_button_state +#num WLC_BUTTON_STATE_RELEASED +#num WLC_BUTTON_STATE_PRESSED + +-- |Axis in interface.pointer.scroll function. +#integral_t enum wlc_scroll_axis_bit +#num WLC_SCROLL_AXIS_VERTICAL +#num WLC_SCROLL_AXIS_HORIZONTAL + +-- |Type in interface.touch.touch function +#integral_t enum wlc_touch_type +#num WLC_TOUCH_DOWN +#num WLC_TOUCH_UP +#num WLC_TOUCH_MOTION +#num WLC_TOUCH_FRAME +#num WLC_TOUCH_CANCEL + +-- |State of keyboard modifiers in various functions. +#starttype struct wlc_modifiers +#field leds, +#field mods, +#stoptype + +-- * Callback API +-- ** Types +-- *** Output +#callback_t output_created_cb , -> IO Bool +#callback_t output_destroyed_cb , -> IO () +#callback_t output_focus_cb , -> Bool -> IO () +#callback_t output_resolution_cb , -> Ptr -> Ptr -> IO () +#callback_t output_render_pre_cb , -> IO () +#callback_t output_render_post_cb , -> IO () +-- *** View +#callback_t view_created_cb , -> IO Bool +#callback_t view_destroyed_cb , -> IO () +#callback_t view_focus_cb , -> Bool -> IO () +#callback_t view_move_to_output_cb , -> -> -> IO () +#callback_t view_request_geometry_cb , -> Ptr -> IO () +#callback_t view_request_state_cb , -> -> Bool -> IO () +#callback_t view_request_move_cb , -> Ptr -> IO () +#callback_t view_request_resize_cb , -> CUInt -> Ptr -> IO () +#callback_t view_render_pre_cb , -> IO () +#callback_t view_render_post_cb , -> IO () +-- *** Input +#callback_t keyboard_key_cb , -> CUInt -> Ptr -> CUInt -> -> IO Bool +#callback_t pointer_button_cb , -> CUInt -> Ptr -> CUInt -> -> Ptr -> IO Bool +#callback_t pointer_scroll_cb , -> CUInt -> Ptr -> -> Double -> IO Bool +#callback_t pointer_motion_cb , -> CUInt -> Ptr -> IO Bool +#callback_t touch_cb , -> CUInt -> Ptr -> -> CInt -> Ptr -> IO Bool +-- *** Other +#callback_t compositor_ready_cb , IO () +#callback_t compositor_terminate_cb , IO () + +-- ** Functions +-- *** Output +-- |Output was created. Return false if you want to destroy the output. (e.g. failed to allocate data related to view) +#ccall wlc_set_output_created_cb , -> IO () +-- |Output was destroyed. +#ccall wlc_set_output_destroyed_cb , -> IO () +-- |Output got or lost focus. +#ccall wlc_set_output_focus_cb , -> IO () +-- |Output resolution changed. +#ccall wlc_set_output_resolution_cb , -> IO () +-- |Output pre render hook. +#ccall wlc_set_output_render_pre_cb , -> IO () +-- |Output post render hook. +#ccall wlc_set_output_render_post_cb , -> IO () +-- *** View +-- |View was created. Return false if you want to destroy the view. (e.g. failed to allocate data related to view) +#ccall wlc_set_view_created_cb , -> IO () +-- |View was destroyed. +#ccall wlc_set_view_destroyed_cb , -> IO () +-- |View got or lost focus. +#ccall wlc_set_view_focus_cb , -> IO () +-- |View was moved to output. +#ccall wlc_set_view_move_to_output_cb , -> IO () +-- |Request to set given geometry for view. Apply using wlc_view_set_geometry to agree. +#ccall wlc_set_view_request_geometry_cb , -> IO () +-- |Request to disable or enable the given state for view. Apply using wlc_view_set_state to agree. +#ccall wlc_set_view_request_state_cb , -> IO () +-- |Request to move itself. Start a interactive move to agree. +#ccall wlc_set_view_request_move_cb , -> IO () +-- |Request to resize itself with the given edges. Start a interactive resize to agree. +#ccall wlc_set_view_request_resize_cb , -> IO () +-- |View pre render hook. +#ccall wlc_set_view_render_pre_cb , -> IO () +-- |View post render hook. +#ccall wlc_set_view_render_post_cb , -> IO () +-- *** Input +-- |Key event was triggered, view handle will be zero if there was no focus. Return true to prevent sending the +-- event to clients. +#ccall wlc_set_keyboard_key_cb , -> IO () +-- |Button event was triggered, view handle will be zero if there was no focus. Return true to prevent sending the +-- event to clients. +#ccall wlc_set_pointer_button_cb , -> IO () +-- |Scroll event was triggered, view handle will be zero if there was no focus. Return true to prevent sending the +-- event to clients. +#ccall wlc_set_pointer_scroll_cb , -> IO () +-- |Motion event was triggered, view handle will be zero if there was no focus. Apply with wlc_pointer_set_position to +-- agree. Return true to prevent sending the event to clients. +#ccall wlc_set_pointer_motion_cb , -> IO () +-- |Touch event was triggered, view handle will be zero if there was no focus. Return true to prevent sending the +-- event to clients. +#ccall wlc_set_touch_cb , -> IO () +-- *** Other +-- |Compositor is ready to accept clients. +#ccall wlc_set_compositor_ready_cb , -> IO () +-- |Compositor is about to terminate +#ccall wlc_set_compositor_terminate_cb , -> IO () + +-- * Core API + +-- |Creates a log handler callback +#callback_t log_handler_cb , -> CString -> IO () + +-- |Set log handler. Can be set before wlc_init. +#ccall wlc_log_set_handler , -> IO () + +-- |Initialize wlc. Returns false on failure. +-- +-- Avoid running unverified code before wlc_init as wlc compositor may be run with higher +-- privileges on non logind systems where compositor binary needs to be suid. +-- +-- wlc_init's purpose is to initialize and drop privileges as soon as possible. +-- +-- Callbacks should be set using wlc_set_*_cb functions before calling wlc_init2, +-- failing to do so will cause any callback the init may trigger to not be called. +#ccall wlc_init2 , IO Bool +-- |Terminate wlc. +#ccall wlc_terminate , IO () +-- |Query backend wlc is using. +#ccall wlc_get_backend_type , IO +-- |Exec program. +#ccall wlc_exec , CString -> Ptr CString -> IO () +-- |Run event loop. +#ccall wlc_run , IO () +-- |Link custom data to handle. +#ccall wlc_handle_set_user_data , -> Ptr () -> IO () +-- |Get linked custom data from handle. +#ccall wlc_handle_get_user_data , -> IO (Ptr ()) + +-- * Output API + +-- |Get outputs. Returned array is a direct reference, careful when moving and destroying handles. +#ccall wlc_get_outputs , Ptr CSize -> IO +-- |Get focused output. +#ccall wlc_get_focused_output , IO +-- |Get output name. +#ccall wlc_output_get_name , -> IO CString +-- |Get sleep state. +#ccall wlc_output_get_sleep , -> IO Bool +-- |Wake up / sleep. +#ccall wlc_output_set_sleep , -> Bool -> IO () +-- |Get resolution. +#ccall wlc_output_get_resolution , -> IO (Ptr ) +-- |Set resolution. +#ccall wlc_output_set_resolution , -> Ptr -> IO () +-- |Get current visibility bitmask. +#ccall wlc_output_get_mask , -> IO CUInt +-- |Set visibility bitmask. +#ccall wlc_output_set_mask , -> CUInt -> IO () +-- |Get views in stack order. Returned array is a direct reference, careful when moving and destroying handles. +#ccall wlc_output_get_views , -> Ptr CSize -> IO (Ptr wlc_handle) +-- |Focus output. Pass zero for no focus. +#ccall wlc_output_focus , -> IO () + +-- * View API +-- |Focus view. Pass zero for no focus. +#ccall wlc_view_focus , -> IO () +-- |Close view. +#ccall wlc_view_close , -> IO () +-- |Get current output. +#ccall wlc_view_get_output , -> IO +-- |Set output. Alternatively you can wlc_output_set_views. +#ccall wlc_view_set_output , -> -> IO () +-- |Send behind everything. +#ccall wlc_view_send_to_back , -> IO () +-- |Send below another view. +#ccall wlc_view_send_below , -> -> IO () +-- |Send above another view. +#ccall wlc_view_bring_above , -> -> IO () +-- |Bring to front of everything. +#ccall wlc_view_bring_to_front , -> IO () +-- |Get current visibility bitmask. +#ccall wlc_view_get_mask , -> IO CUInt +-- |Set visibility bitmask. +#ccall wlc_view_set_mask , -> CUInt -> IO () +-- |Get current geometry. (what client sees) +#ccall wlc_view_get_geometry , -> IO (Ptr ) +-- |Get visible geometry. (what wlc displays) +#ccall wlc_view_get_visible_geometry , -> Ptr -> IO () +-- |Set geometry. Set edges if the geometry change is caused by interactive resize. +#ccall wlc_view_set_geometry , -> CUInt -> Ptr -> IO () +-- |Get type bitfield. +#ccall wlc_view_get_type , -> IO CUInt +-- |Set type bit. Toggle indicates whether it is set or not. +#ccall wlc_view_set_type , -> -> Bool -> IO () +-- |Get current state bitfield. +#ccall wlc_view_get_state , -> IO CUInt +-- |Set state bit. Toggle indicates whether it is set or not. +#ccall wlc_view_set_state , -> -> Bool -> IO () +-- |Get parent view. +#ccall wlc_view_get_parent , -> IO +-- |Set parent view. +#ccall wlc_view_set_parent , -> -> IO () +-- |Get title. +#ccall wlc_view_get_title , -> IO CString +-- |Get class. (shell-surface only) +#ccall wlc_view_get_class , -> IO CString +-- |Get app id. (xdg-surface only) +#ccall wlc_view_get_app_id , -> IO CString + +-- * Input API +-- |Get currently held keys. +#ccall wlc_keyboard_get_current_keys , Ptr CSize -> IO (Ptr CUInt) +-- |Utility function to convert raw keycode to keysym. Passed modifiers may transform the key. +#ccall wlc_keyboard_get_keysym_for_key , CUInt -> Ptr -> IO CUInt +-- |Utility function to convert raw keycode to Unicode/UTF-32 codepoint. Passed modifiers may transform the key. +#ccall wlc_keyboard_get_utf32_for_key , CUInt -> Ptr -> IO CUInt +-- |Get current pointer position. +#ccall wlc_pointer_get_position , Ptr -> IO () +-- |Set current pointer position. +#ccall wlc_pointer_set_position , Ptr -> IO () diff --git a/src/Bindings/WLC/Render.hsc b/src/Bindings/WLC/Render.hsc new file mode 100644 --- /dev/null +++ b/src/Bindings/WLC/Render.hsc @@ -0,0 +1,67 @@ +#include +#include + +{-| +Module : Bindings.WLC.WLCRender +Description : WLC Render +Copyright : (c) Ashley Towns 2016 +License : BSD3 +Maintainer : mail@ashleytowns.id.au +Stability : experimental +Portability : POSIX + +The functions in this file provide some basic rendering capabilities. +*_render(), *_read(), *_write() functions should only be called during post/pre render callbacks. +wlc_output_schedule_render() is exception and may be used to force wlc to render new frame (causing callbacks to trigger). + +For more advanced drawing you should directly use GLES2. +This is not documented as it's currently relying on the implementation details of wlc. +-} +module Bindings.WLC.Render where +#strict_import + +import Bindings.WLC.Defines +import Bindings.WLC.Geometry +import Bindings.WLC.Wayland + +-- |Allowed pixel formats. +#integral_t enum wlc_pixel_format +#num WLC_RGBA8888 + +-- |Write pixel data with the specific format to output's framebuffer. +-- If the geometry is out of bounds, it will be automaticall clamped. +#ccall wlc_pixels_write , -> Ptr -> Ptr () -> IO () + +-- |Read pixel data from output's framebuffer. +-- If the geometry is out of bounds, it will be automatically clamped. +-- Potentially clamped geometry will be stored in out_geometry, to indicate width / height of the returned data. +#ccall wlc_pixels_read , -> Ptr -> Ptr -> Ptr () -> IO () + +-- |Renders surface. +#ccall wlc_surface_render , -> Ptr -> IO () + +-- |Schedules output for rendering next frame. If output was already scheduled this is no-op, +-- if output is currently rendering, it will render immediately after. +#ccall wlc_output_schedule_render , -> IO () + +-- |Adds frame callbacks of the given surface for the next output frame. +-- It applies recursively to all subsurfaces. +-- Useful when the compositor creates custom animations which require disabling internal rendering, +-- but still need to update the surface textures (for ex. video players). +#ccall wlc_surface_flush_frame_callbacks , -> IO () + +-- |Enabled renderers +#integral_t enum wlc_renderer +#num WLC_RENDERER_GLES2 +#num WLC_NO_RENDERER + +-- |Returns currently active renderer on the given output +#ccall wlc_output_get_renderer , -> IO + +#integral_t enum wlc_surface_format +#num SURFACE_RGB +#num SURFACE_RGBA +#num SURFACE_EGL +#num SURFACE_Y_UV +#num SURFACE_Y_U_V +#num SURFACE_Y_XUXV diff --git a/src/Bindings/WLC/WLC.hsc b/src/Bindings/WLC/WLC.hsc deleted file mode 100644 --- a/src/Bindings/WLC/WLC.hsc +++ /dev/null @@ -1,324 +0,0 @@ -#include -#include - -{-| -Module : Bindings.WLC.WLC -Description : Core WLC -Copyright : (c) Ashley Towns 2016 -License : BSD3 -Maintainer : mail@ashleytowns.id.au -Stability : experimental -Portability : POSIX - -Provides bindings to the core WLC API. --} -module Bindings.WLC.WLC where -#strict_import - -import Bindings.WLC.Defines -import Bindings.WLC.Geometry - -#opaque_t wlc_event_source -#opaque_t xkb_state -#opaque_t xkb_keymap -#opaque_t libinput_device - --- |wlc_log(), wlc_vlog(); -#integral_t enum wlc_log_type -#num WLC_LOG_INFO -#num WLC_LOG_WARN -#num WLC_LOG_ERROR -#num WLC_LOG_WAYLAND - --- |wlc_get_backend_type(); -#integral_t enum wlc_backend_type -#num WLC_BACKEND_NONE -#num WLC_BACKEND_DRM -#num WLC_BACKEND_X11 - --- |mask in wlc_event_loop_add_fd(); -#integral_t enum wlc_event_bit -#num WLC_EVENT_READABLE -#num WLC_EVENT_WRITABLE -#num WLC_EVENT_HANGUP -#num WLC_EVENT_ERROR - --- |wlc_view_get_state(); -#integral_t enum wlc_view_state_bit -#num WLC_BIT_MAXIMIZED -#num WLC_BIT_FULLSCREEN -#num WLC_BIT_RESIZING -#num WLC_BIT_MOVING -#num WLC_BIT_ACTIVATED - --- |wlc_view_get_type(); -#integral_t enum wlc_view_type_bit --- |Override redirect (x11) -#num WLC_BIT_OVERRIDE_REDIRECT --- |Tooltips, DnD's, menus (x11) -#num WLC_BIT_UNMANAGED --- |Splash screens (x11) -#num WLC_BIT_SPLASH --- |Modal windows (x11) -#num WLC_BIT_MODAL --- |xdg-shell, wl-shell popups -#num WLC_BIT_POPUP - --- |wlc_view_set_geometry(); Edges in interface interface.view.request.resize function. -#integral_t enum wlc_resize_edge -#num WLC_RESIZE_EDGE_NONE -#num WLC_RESIZE_EDGE_TOP -#num WLC_RESIZE_EDGE_BOTTOM -#num WLC_RESIZE_EDGE_LEFT -#num WLC_RESIZE_EDGE_TOP_LEFT -#num WLC_RESIZE_EDGE_BOTTOM_LEFT -#num WLC_RESIZE_EDGE_RIGHT -#num WLC_RESIZE_EDGE_TOP_RIGHT -#num WLC_RESIZE_EDGE_BOTTOM_RIGHT - --- |Mods in interface.keyboard.key function. -#integral_t enum wlc_modifier_bit -#num WLC_BIT_MOD_SHIFT -#num WLC_BIT_MOD_CAPS -#num WLC_BIT_MOD_CTRL -#num WLC_BIT_MOD_ALT -#num WLC_BIT_MOD_MOD2 -#num WLC_BIT_MOD_MOD3 -#num WLC_BIT_MOD_LOGO -#num WLC_BIT_MOD_MOD5 - --- |Leds in interface.keyboard.key function. -#integral_t enum wlc_led_bit -#num WLC_BIT_LED_NUM -#num WLC_BIT_LED_CAPS -#num WLC_BIT_LED_SCROLL - --- |State in interface.keyboard.key function. -#integral_t enum wlc_key_state -#num WLC_KEY_STATE_RELEASED -#num WLC_KEY_STATE_PRESSED - --- |State in interface.pointer.button function. -#integral_t enum wlc_button_state -#num WLC_BUTTON_STATE_RELEASED -#num WLC_BUTTON_STATE_PRESSED - --- |Axis in interface.pointer.scroll function. -#integral_t enum wlc_scroll_axis_bit -#num WLC_SCROLL_AXIS_VERTICAL -#num WLC_SCROLL_AXIS_HORIZONTAL - --- |Type in interface.touch.touch function -#integral_t enum wlc_touch_type -#num WLC_TOUCH_DOWN -#num WLC_TOUCH_UP -#num WLC_TOUCH_MOTION -#num WLC_TOUCH_FRAME -#num WLC_TOUCH_CANCEL - --- |State of keyboard modifiers in various functions. -#starttype struct wlc_modifiers -#field leds, CUInt -#field mods, CUInt -#stoptype - --- * Callback API --- ** Types --- *** Output -#callback_t output_created_cb , -> IO Bool -#callback_t output_destroyed_cb , -> IO () -#callback_t output_focus_cb , -> Bool -> IO () -#callback_t output_resolution_cb , -> Ptr -> Ptr -> IO () -#callback_t output_render_pre_cb , -> IO () -#callback_t output_render_post_cb , -> IO () --- *** View -#callback_t view_created_cb , -> IO Bool -#callback_t view_destroyed_cb , -> IO () -#callback_t view_focus_cb , -> Bool -> IO () -#callback_t view_move_to_output_cb , -> -> -> IO () -#callback_t view_request_geometry_cb , -> Ptr -> IO () -#callback_t view_request_state_cb , -> -> Bool -> IO () -#callback_t view_request_move_cb , -> Ptr -> IO () -#callback_t view_request_resize_cb , -> CUInt -> Ptr -> IO () -#callback_t view_render_pre_cb , -> IO () -#callback_t view_render_post_cb , -> IO () --- *** Input -#callback_t keyboard_key_cb , -> CUInt -> Ptr -> CUInt -> -> IO Bool -#callback_t pointer_button_cb , -> CUInt -> Ptr -> CUInt -> -> Ptr -> IO Bool -#callback_t pointer_scroll_cb , -> CUInt -> Ptr -> Int8 -> CDouble -> IO Bool -#callback_t pointer_motion_cb , -> CUInt -> Ptr -> IO Bool -#callback_t touch_cb , -> CUInt -> Ptr -> -> CInt -> Ptr -> IO Bool --- *** Other -#callback_t compositor_ready_cb , IO () -#callback_t compositor_terminate_cb , IO () - --- ** Functions --- *** Output --- |Output was created. Return false if you want to destroy the output. (e.g. failed to allocate data related to view) -#ccall wlc_set_output_created_cb , -> IO () --- |Output was destroyed. -#ccall wlc_set_output_destroyed_cb , -> IO () --- |Output got or lost focus. -#ccall wlc_set_output_focus_cb , -> IO () --- |Output resolution changed. -#ccall wlc_set_output_resolution_cb , -> IO () --- |Output pre render hook. -#ccall wlc_set_output_render_pre_cb , -> IO () --- |Output post render hook. -#ccall wlc_set_output_render_post_cb , -> IO () --- *** View --- |View was created. Return false if you want to destroy the view. (e.g. failed to allocate data related to view) -#ccall wlc_set_view_created_cb , -> IO () --- |View was destroyed. -#ccall wlc_set_view_destroyed_cb , -> IO () --- |View got or lost focus. -#ccall wlc_set_view_focus_cb , -> IO () --- |View was moved to output. -#ccall wlc_set_view_move_to_output_cb , -> IO () --- |Request to set given geometry for view. Apply using wlc_view_set_geometry to agree. -#ccall wlc_set_view_request_geometry_cb , -> IO () --- |Request to disable or enable the given state for view. Apply using wlc_view_set_state to agree. -#ccall wlc_set_view_request_state_cb , -> IO () --- |Request to move itself. Start a interactive move to agree. -#ccall wlc_set_view_request_move_cb , -> IO () --- |Request to resize itself with the given edges. Start a interactive resize to agree. -#ccall wlc_set_view_request_resize_cb , -> IO () --- |View pre render hook. -#ccall wlc_set_view_render_pre_cb , -> IO () --- |View post render hook. -#ccall wlc_set_view_render_post_cb , -> IO () --- *** Input --- |Key event was triggered, view handle will be zero if there was no focus. Return true to prevent sending the --- event to clients. -#ccall wlc_set_keyboard_key_cb , -> IO () --- |Button event was triggered, view handle will be zero if there was no focus. Return true to prevent sending the --- event to clients. -#ccall wlc_set_pointer_button_cb , -> IO () --- |Scroll event was triggered, view handle will be zero if there was no focus. Return true to prevent sending the --- event to clients. -#ccall wlc_set_pointer_scroll_cb , -> IO () --- |Motion event was triggered, view handle will be zero if there was no focus. Apply with wlc_pointer_set_position to --- agree. Return true to prevent sending the event to clients. -#ccall wlc_set_pointer_motion_cb , -> IO () --- |Touch event was triggered, view handle will be zero if there was no focus. Return true to prevent sending the --- event to clients. -#ccall wlc_set_touch_cb , -> IO () --- *** Other --- |Compositor is ready to accept clients. -#ccall wlc_set_compositor_ready_cb , -> IO () --- |Compositor is about to terminate -#ccall wlc_set_compositor_terminate_cb , -> IO () - --- * Core API - --- |Creates a log handler callback -#callback_t log_handler_cb , -> CString -> IO () - --- |Set log handler. Can be set before wlc_init. -#ccall wlc_log_set_handler , -> IO () - --- |Initialize wlc. Returns false on failure. --- --- Avoid running unverified code before wlc_init as wlc compositor may be run with higher --- privileges on non logind systems where compositor binary needs to be suid. --- --- wlc_init's purpose is to initialize and drop privileges as soon as possible. --- --- Callbacks should be set using wlc_set_*_cb functions before calling wlc_init2, --- failing to do so will cause any callback the init may trigger to not be called. -#ccall wlc_init2 , IO Bool --- |Terminate wlc. -#ccall wlc_terminate , IO () --- |Query backend wlc is using. -#ccall wlc_get_backend_type , IO --- |Exec program. -#ccall wlc_exec , CString -> Ptr CString -> IO () --- |Run event loop. -#ccall wlc_run , IO () --- |Link custom data to handle. -#ccall wlc_handle_set_user_data , -> Ptr () -> IO () --- |Get linked custom data from handle. -#ccall wlc_handle_get_user_data , -> IO (Ptr ()) - --- * Output API - --- |Get outputs. Returned array is a direct reference, careful when moving and destroying handles. -#ccall wlc_get_outputs , Ptr CSize -> IO --- |Get focused output. -#ccall wlc_get_focused_output , IO --- |Get output name. -#ccall wlc_output_get_name , -> IO CString --- |Get sleep state. -#ccall wlc_output_get_sleep , -> IO Bool --- |Wake up / sleep. -#ccall wlc_output_set_sleep , -> Bool -> IO () --- |Get resolution. -#ccall wlc_output_get_resolution , -> IO (Ptr ) --- |Set resolution. -#ccall wlc_output_set_resolution , -> Ptr -> IO () --- |Get current visibility bitmask. -#ccall wlc_output_get_mask , -> IO CUInt --- |Set visibility bitmask. -#ccall wlc_output_set_mask , -> CUInt -> IO () --- |Get views in stack order. Returned array is a direct reference, careful when moving and destroying handles. -#ccall wlc_output_get_views , -> Ptr CSize -> IO (Ptr wlc_handle) --- |Focus output. Pass zero for no focus. -#ccall wlc_output_focus , -> IO () - --- * View API --- |Focus view. Pass zero for no focus. -#ccall wlc_view_focus , -> IO () --- |Close view. -#ccall wlc_view_close , -> IO () --- |Get current output. -#ccall wlc_view_get_output , -> IO --- |Set output. Alternatively you can wlc_output_set_views. -#ccall wlc_view_set_output , -> -> IO () --- |Send behind everything. -#ccall wlc_view_send_to_back , -> IO () --- |Send below another view. -#ccall wlc_view_send_below , -> -> IO () --- |Send above another view. -#ccall wlc_view_bring_above , -> -> IO () --- |Bring to front of everything. -#ccall wlc_view_bring_to_front , -> IO () --- |Get current visibility bitmask. -#ccall wlc_view_get_mask , -> IO CUInt --- |Set visibility bitmask. -#ccall wlc_view_set_mask , -> CUInt -> IO () --- |Get current geometry. (what client sees) -#ccall wlc_view_get_geometry , -> IO (Ptr ) --- |Get visible geometry. (what wlc displays) -#ccall wlc_view_get_visible_geometry , -> Ptr -> IO () --- |Set geometry. Set edges if the geometry change is caused by interactive resize. -#ccall wlc_view_set_geometry , -> CUInt -> Ptr -> IO () --- |Get type bitfield. -#ccall wlc_view_get_type , -> IO CUInt --- |Set type bit. Toggle indicates whether it is set or not. -#ccall wlc_view_set_type , -> -> Bool -> IO () --- |Get current state bitfield. -#ccall wlc_view_get_state , -> IO CUInt --- |Set state bit. Toggle indicates whether it is set or not. -#ccall wlc_view_set_state , -> -> Bool -> IO () --- |Get parent view. -#ccall wlc_view_get_parent , -> IO --- |Set parent view. -#ccall wlc_view_set_parent , -> -> IO () --- |Get title. -#ccall wlc_view_get_title , -> IO CString --- |Get class. (shell-surface only) -#ccall wlc_view_get_class , -> IO CString --- |Get app id. (xdg-surface only) -#ccall wlc_view_get_app_id , -> IO CString - --- * Input API --- |Get currently held keys. -#ccall wlc_keyboard_get_current_keys , Ptr CSize -> IO (Ptr CUInt) --- |Utility function to convert raw keycode to keysym. Passed modifiers may transform the key. -#ccall wlc_keyboard_get_keysym_for_key , CUInt -> Ptr -> IO CUInt --- |Utility function to convert raw keycode to Unicode/UTF-32 codepoint. Passed modifiers may transform the key. -#ccall wlc_keyboard_get_utf32_for_key , CUInt -> Ptr -> IO CUInt --- |Get current pointer position. -#ccall wlc_pointer_get_position , Ptr -> IO () --- |Set current pointer position. -#ccall wlc_pointer_set_position , Ptr -> IO () diff --git a/src/Bindings/WLC/WLCRender.hsc b/src/Bindings/WLC/WLCRender.hsc deleted file mode 100644 --- a/src/Bindings/WLC/WLCRender.hsc +++ /dev/null @@ -1,67 +0,0 @@ -#include -#include - -{-| -Module : Bindings.WLC.WLCRender -Description : WLC Render -Copyright : (c) Ashley Towns 2016 -License : BSD3 -Maintainer : mail@ashleytowns.id.au -Stability : experimental -Portability : POSIX - -The functions in this file provide some basic rendering capabilities. -*_render(), *_read(), *_write() functions should only be called during post/pre render callbacks. -wlc_output_schedule_render() is exception and may be used to force wlc to render new frame (causing callbacks to trigger). - -For more advanced drawing you should directly use GLES2. -This is not documented as it's currently relying on the implementation details of wlc. --} -module Bindings.WLC.WLCRender where -#strict_import - -import Bindings.WLC.Defines -import Bindings.WLC.Geometry -import Bindings.WLC.WLCWayland - --- |Allowed pixel formats. -#integral_t enum wlc_pixel_format -#num WLC_RGBA8888 - --- |Write pixel data with the specific format to output's framebuffer. --- If the geometry is out of bounds, it will be automaticall clamped. -#ccall wlc_pixels_write , -> Ptr -> Ptr () -> IO () - --- |Read pixel data from output's framebuffer. --- If the geometry is out of bounds, it will be automatically clamped. --- Potentially clamped geometry will be stored in out_geometry, to indicate width / height of the returned data. -#ccall wlc_pixels_read , -> Ptr -> Ptr -> Ptr () -> IO () - --- |Renders surface. -#ccall wlc_surface_render , -> Ptr -> IO () - --- |Schedules output for rendering next frame. If output was already scheduled this is no-op, --- if output is currently rendering, it will render immediately after. -#ccall wlc_output_schedule_render , -> IO () - --- |Adds frame callbacks of the given surface for the next output frame. --- It applies recursively to all subsurfaces. --- Useful when the compositor creates custom animations which require disabling internal rendering, --- but still need to update the surface textures (for ex. video players). -#ccall wlc_surface_flush_frame_callbacks , -> IO () - --- |Enabled renderers -#integral_t enum wlc_renderer -#num WLC_RENDERER_GLES2 -#num WLC_NO_RENDERER - --- |Returns currently active renderer on the given output -#ccall wlc_output_get_renderer , -> IO - -#integral_t enum wlc_surface_format -#num SURFACE_RGB -#num SURFACE_RGBA -#num SURFACE_EGL -#num SURFACE_Y_UV -#num SURFACE_Y_U_V -#num SURFACE_Y_XUXV diff --git a/src/Bindings/WLC/WLCWayland.hsc b/src/Bindings/WLC/WLCWayland.hsc deleted file mode 100644 --- a/src/Bindings/WLC/WLCWayland.hsc +++ /dev/null @@ -1,53 +0,0 @@ -#include -#include - -{-| -Module : Bindings.WLC.WLCWayland -Description : WLC Wayland -Copyright : (c) Ashley Towns 2016 -License : BSD3 -Maintainer : mail@ashleytowns.id.au -Stability : experimental -Portability : POSIX --} -module Bindings.WLC.WLCWayland where -#strict_import - -import Bindings.WLC.Defines -import Bindings.WLC.Geometry - -#synonym_t wlc_resource , CUIntPtr - -#opaque_t wl_resource -#opaque_t wl_display - -#opaque_t wl_client -#opaque_t wl_interface - --- |Returns Wayland display. -#ccall wlc_get_wl_display , IO (Ptr ) --- |Returns view handle from wl_surface resource. -#ccall wlc_handle_from_wl_surface_resource , Ptr -> IO --- |Returns output handle from wl_output resource. -#ccall wlc_handle_from_wl_output_resource , Ptr -> IO --- |Returns internal wlc surface from wl_surface resource. -#ccall wlc_resource_from_wl_surface_resource , Ptr -> IO --- |Get surface size. -#ccall wlc_surface_get_size , -> IO (Ptr ) --- |Return wl_surface resource from internal wlc surface. -#ccall wlc_surface_get_wl_resource , -> IO (Ptr ) --- |Turns wl_surface into a wlc view. Returns 0 on failure. This will also trigger view.created callback as any view would. --- For the extra arguments see details of wl_resource_create and wl_resource_set_implementation. --- The extra arguments may be set NULL, if you are not implementing Wayland interface for the surface role. -#ccall wlc_view_from_surface , -> Ptr -> Ptr -> Ptr () -> CUInt -> CUInt -> Ptr () -> IO --- |Returns internal wlc surface from view handle -#ccall wlc_view_get_surface , -> IO --- |Returns a list of the subsurfaces of the given surface -#ccall wlc_surface_get_subsurfaces , -> Ptr CSize -> IO (Ptr ) --- |Returns the size of a subsurface and its position relative to parent -#ccall wlc_get_subsurface_geometry , -> Ptr -> IO () --- |Returns wl_client from view handle -#ccall wlc_view_get_wl_client , -> IO (Ptr ) --- |Returns surface role resource from view handle. Return value will be NULL if the view was not assigned role --- or created with wlc_view_create_from_surface(). -#ccall wlc_view_get_role , -> IO (Ptr ) diff --git a/src/Bindings/WLC/Wayland.hsc b/src/Bindings/WLC/Wayland.hsc new file mode 100644 --- /dev/null +++ b/src/Bindings/WLC/Wayland.hsc @@ -0,0 +1,53 @@ +#include +#include + +{-| +Module : Bindings.WLC.WLCWayland +Description : WLC Wayland +Copyright : (c) Ashley Towns 2016 +License : BSD3 +Maintainer : mail@ashleytowns.id.au +Stability : experimental +Portability : POSIX +-} +module Bindings.WLC.Wayland where +#strict_import + +import Bindings.WLC.Defines +import Bindings.WLC.Geometry + +#synonym_t wlc_resource , CUIntPtr + +#opaque_t wl_resource +#opaque_t wl_display + +#opaque_t wl_client +#opaque_t wl_interface + +-- |Returns Wayland display. +#ccall wlc_get_wl_display , IO (Ptr ) +-- |Returns view handle from wl_surface resource. +#ccall wlc_handle_from_wl_surface_resource , Ptr -> IO +-- |Returns output handle from wl_output resource. +#ccall wlc_handle_from_wl_output_resource , Ptr -> IO +-- |Returns internal wlc surface from wl_surface resource. +#ccall wlc_resource_from_wl_surface_resource , Ptr -> IO +-- |Get surface size. +#ccall wlc_surface_get_size , -> IO (Ptr ) +-- |Return wl_surface resource from internal wlc surface. +#ccall wlc_surface_get_wl_resource , -> IO (Ptr ) +-- |Turns wl_surface into a wlc view. Returns 0 on failure. This will also trigger view.created callback as any view would. +-- For the extra arguments see details of wl_resource_create and wl_resource_set_implementation. +-- The extra arguments may be set NULL, if you are not implementing Wayland interface for the surface role. +#ccall wlc_view_from_surface , -> Ptr -> Ptr -> Ptr () -> CUInt -> CUInt -> Ptr () -> IO +-- |Returns internal wlc surface from view handle +#ccall wlc_view_get_surface , -> IO +-- |Returns a list of the subsurfaces of the given surface +#ccall wlc_surface_get_subsurfaces , -> Ptr CSize -> IO (Ptr ) +-- |Returns the size of a subsurface and its position relative to parent +#ccall wlc_get_subsurface_geometry , -> Ptr -> IO () +-- |Returns wl_client from view handle +#ccall wlc_view_get_wl_client , -> IO (Ptr ) +-- |Returns surface role resource from view handle. Return value will be NULL if the view was not assigned role +-- or created with wlc_view_create_from_surface(). +#ccall wlc_view_get_role , -> IO (Ptr ) diff --git a/src/System/WLC.hs b/src/System/WLC.hs new file mode 100644 --- /dev/null +++ b/src/System/WLC.hs @@ -0,0 +1,4 @@ +module System.WLC where + +import System.WLC.Geometry +import System.WLC.Core diff --git a/src/System/WLC/Core.hs b/src/System/WLC/Core.hs new file mode 100644 --- /dev/null +++ b/src/System/WLC/Core.hs @@ -0,0 +1,474 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +module System.WLC.Core where + +import Bindings.WLC.Defines +import Bindings.WLC.Core +import System.WLC.Geometry +import System.WLC.Utilities +import Data.Word(Word8, Word32) +import Control.Monad(liftM2) +import Foreign.Ptr(nullPtr) +import Foreign.C.String(peekCString, withCString, newCString) +import Foreign.Marshal.Array(withArray0) +import Foreign.Marshal.Alloc(free, alloca) +import Foreign.Marshal.Utils(with) +import Data.Convertible.Base +import Data.Convertible.Instances.C + +-- Wrappers around the type synonyms so we can add the Primitive instances. +newtype WlcLogType = WlcLogType C'wlc_log_type deriving (Show) +newtype WlcBackendType = WlcBackendType C'wlc_backend_type deriving (Show) +newtype WlcEventBit = WlcEventBit C'wlc_event_bit deriving (Show) +newtype WlcViewStateBit = WlcViewStateBit { getViewStateBit :: C'wlc_view_state_bit } deriving (Show) +newtype WlcViewTypeBit = WlcViewTypeBit { getViewTypeBit :: C'wlc_view_type_bit } deriving (Show) +newtype WlcResizeEdge = WlcResizeEdge C'wlc_resize_edge deriving (Show) +newtype WlcModifierBit = WlcModifierBit { getModifierBit :: C'wlc_modifier_bit } deriving (Show) +newtype WlcLedBit = WlcLedBit { getLedBit :: C'wlc_led_bit } deriving (Show) +newtype WlcKeyState = WlcKeyState C'wlc_key_state deriving (Show) +newtype WlcButtonState = WlcButtonState C'wlc_button_state deriving (Show) +newtype WlcScrollAxisBit = WlcScrollAxisBit C'wlc_scroll_axis_bit deriving (Show) +newtype WlcTouchType = WlcTouchType C'wlc_touch_type deriving (Show) + +data LogType = LogInfo + | LogWarn + | LogError + | LogWayland deriving (Eq, Show) + +instance Primitive WlcLogType LogType where + fromPrimitive (WlcLogType x) + | x == c'WLC_LOG_INFO = LogInfo + | x == c'WLC_LOG_WARN = LogWarn + | x == c'WLC_LOG_ERROR = LogError + | x == c'WLC_LOG_WAYLAND = LogWayland + | otherwise = error $ "unexpected logger given: " ++ show x + + toPrimitive LogInfo = WlcLogType c'WLC_LOG_INFO + toPrimitive LogWarn = WlcLogType c'WLC_LOG_WARN + toPrimitive LogError = WlcLogType c'WLC_LOG_ERROR + toPrimitive LogWayland = WlcLogType c'WLC_LOG_WAYLAND + +data BackendType = BackendNone + | BackendDRM + | BackendX11 deriving (Eq, Show) + +instance Primitive WlcBackendType BackendType where + fromPrimitive (WlcBackendType x) + | x == c'WLC_BACKEND_NONE = BackendNone + | x == c'WLC_BACKEND_DRM = BackendDRM + | x == c'WLC_BACKEND_X11 = BackendX11 + | otherwise = error $ "unexpected backend given: " ++ show x + + toPrimitive BackendNone = WlcBackendType c'WLC_BACKEND_NONE + toPrimitive BackendDRM = WlcBackendType c'WLC_BACKEND_DRM + toPrimitive BackendX11 = WlcBackendType c'WLC_BACKEND_X11 + +data EventBit = EventReadable + | EventWritable + | EventHangup + | EventError deriving (Eq, Show) + +instance Primitive WlcEventBit EventBit where + fromPrimitive (WlcEventBit x) + | x == c'WLC_EVENT_READABLE = EventReadable + | x == c'WLC_EVENT_WRITABLE = EventWritable + | x == c'WLC_EVENT_HANGUP = EventHangup + | x == c'WLC_EVENT_ERROR = EventError + | otherwise = error $ "unexpected event bit given: " ++ show x + + toPrimitive EventReadable = WlcEventBit c'WLC_EVENT_READABLE + toPrimitive EventWritable = WlcEventBit c'WLC_EVENT_WRITABLE + toPrimitive EventHangup = WlcEventBit c'WLC_EVENT_HANGUP + toPrimitive EventError = WlcEventBit c'WLC_EVENT_ERROR + +data ViewState = ViewMaximized + | ViewFullscreen + | ViewResizing + | ViewMoving + | ViewActivated deriving (Eq, Show) + +instance Primitive WlcViewStateBit ViewState where + fromPrimitive (WlcViewStateBit x) + | x == c'WLC_BIT_MAXIMIZED = ViewMaximized + | x == c'WLC_BIT_FULLSCREEN = ViewFullscreen + | x == c'WLC_BIT_RESIZING = ViewResizing + | x == c'WLC_BIT_MOVING = ViewMoving + | x == c'WLC_BIT_ACTIVATED = ViewActivated + | otherwise = error $ "unexpected view state bit given: " ++ show x + + toPrimitive ViewMaximized = WlcViewStateBit c'WLC_BIT_MAXIMIZED + toPrimitive ViewFullscreen = WlcViewStateBit c'WLC_BIT_FULLSCREEN + toPrimitive ViewResizing = WlcViewStateBit c'WLC_BIT_RESIZING + toPrimitive ViewMoving = WlcViewStateBit c'WLC_BIT_MOVING + toPrimitive ViewActivated = WlcViewStateBit c'WLC_BIT_ACTIVATED + +data ViewType = ViewOverrideRedirect + | ViewUnmanaged + | ViewSplash + | ViewModal + | ViewPopup deriving (Eq, Show) + +instance Primitive WlcViewTypeBit ViewType where + fromPrimitive (WlcViewTypeBit x) + | x == c'WLC_BIT_OVERRIDE_REDIRECT = ViewOverrideRedirect + | x == c'WLC_BIT_UNMANAGED = ViewUnmanaged + | x == c'WLC_BIT_SPLASH = ViewSplash + | x == c'WLC_BIT_MODAL = ViewModal + | x == c'WLC_BIT_POPUP = ViewPopup + | otherwise = error $ "unexpected view type bit given: " ++ show x + + toPrimitive ViewOverrideRedirect = WlcViewTypeBit c'WLC_BIT_OVERRIDE_REDIRECT + toPrimitive ViewUnmanaged = WlcViewTypeBit c'WLC_BIT_UNMANAGED + toPrimitive ViewSplash = WlcViewTypeBit c'WLC_BIT_SPLASH + toPrimitive ViewModal = WlcViewTypeBit c'WLC_BIT_MODAL + toPrimitive ViewPopup = WlcViewTypeBit c'WLC_BIT_POPUP + +data ResizeEdge = EdgeNone + | EdgeTop + | EdgeBottom + | EdgeLeft + | EdgeTopLeft + | EdgeBottomLeft + | EdgeRight + | EdgeTopRight + | EdgeBottomRight deriving (Eq, Show) + +instance Primitive WlcResizeEdge ResizeEdge where + fromPrimitive (WlcResizeEdge x) + | x == c'WLC_RESIZE_EDGE_NONE = EdgeNone + | x == c'WLC_RESIZE_EDGE_TOP = EdgeTop + | x == c'WLC_RESIZE_EDGE_BOTTOM = EdgeBottom + | x == c'WLC_RESIZE_EDGE_LEFT = EdgeLeft + | x == c'WLC_RESIZE_EDGE_TOP_LEFT = EdgeTopLeft + | x == c'WLC_RESIZE_EDGE_BOTTOM_LEFT = EdgeBottomLeft + | x == c'WLC_RESIZE_EDGE_RIGHT = EdgeRight + | x == c'WLC_RESIZE_EDGE_TOP_RIGHT = EdgeTopRight + | x == c'WLC_RESIZE_EDGE_BOTTOM_RIGHT = EdgeBottomRight + | otherwise = error $ "unexpected resize edge bit given: " ++ show x + + toPrimitive EdgeNone = WlcResizeEdge c'WLC_RESIZE_EDGE_NONE + toPrimitive EdgeTop = WlcResizeEdge c'WLC_RESIZE_EDGE_TOP + toPrimitive EdgeBottom = WlcResizeEdge c'WLC_RESIZE_EDGE_BOTTOM + toPrimitive EdgeLeft = WlcResizeEdge c'WLC_RESIZE_EDGE_LEFT + toPrimitive EdgeTopLeft = WlcResizeEdge c'WLC_RESIZE_EDGE_TOP_LEFT + toPrimitive EdgeBottomLeft = WlcResizeEdge c'WLC_RESIZE_EDGE_BOTTOM_LEFT + toPrimitive EdgeRight = WlcResizeEdge c'WLC_RESIZE_EDGE_RIGHT + toPrimitive EdgeTopRight = WlcResizeEdge c'WLC_RESIZE_EDGE_TOP_RIGHT + toPrimitive EdgeBottomRight = WlcResizeEdge c'WLC_RESIZE_EDGE_BOTTOM_RIGHT + +data Modifier = Shift + | Caps + | CTRL + | Alt + | Mod2 + | Mod3 + | ModLogo + | Mod5 deriving (Eq, Show) + +instance Primitive WlcModifierBit Modifier where + fromPrimitive (WlcModifierBit x) + | x == c'WLC_BIT_MOD_SHIFT = Shift + | x == c'WLC_BIT_MOD_CAPS = Caps + | x == c'WLC_BIT_MOD_CTRL = CTRL + | x == c'WLC_BIT_MOD_ALT = Alt + | x == c'WLC_BIT_MOD_MOD2 = Mod2 + | x == c'WLC_BIT_MOD_MOD3 = Mod3 + | x == c'WLC_BIT_MOD_LOGO = ModLogo + | x == c'WLC_BIT_MOD_MOD5 = Mod5 + | otherwise = error $ "unexpected modifier bit given: " ++ show x + + toPrimitive Shift = WlcModifierBit c'WLC_BIT_MOD_SHIFT + toPrimitive Caps = WlcModifierBit c'WLC_BIT_MOD_CAPS + toPrimitive CTRL = WlcModifierBit c'WLC_BIT_MOD_CTRL + toPrimitive Alt = WlcModifierBit c'WLC_BIT_MOD_ALT + toPrimitive Mod2 = WlcModifierBit c'WLC_BIT_MOD_MOD2 + toPrimitive Mod3 = WlcModifierBit c'WLC_BIT_MOD_MOD3 + toPrimitive ModLogo = WlcModifierBit c'WLC_BIT_MOD_LOGO + toPrimitive Mod5 = WlcModifierBit c'WLC_BIT_MOD_MOD5 + +data Led = LedNum + | LedCaps + | LedScroll deriving (Eq, Show) + +instance Primitive WlcLedBit Led where + fromPrimitive (WlcLedBit x) + | x == c'WLC_BIT_LED_NUM = LedNum + | x == c'WLC_BIT_LED_CAPS = LedCaps + | x == c'WLC_BIT_LED_SCROLL = LedScroll + | otherwise = error $ "unexpected led bit given: " ++ show x + + toPrimitive LedNum = WlcLedBit c'WLC_BIT_LED_NUM + toPrimitive LedCaps = WlcLedBit c'WLC_BIT_LED_CAPS + toPrimitive LedScroll = WlcLedBit c'WLC_BIT_LED_SCROLL + +data KeyState = KeyReleased | KeyPressed deriving (Eq, Show) + +instance Primitive WlcKeyState KeyState where + fromPrimitive (WlcKeyState x) + | x == c'WLC_KEY_STATE_RELEASED = KeyReleased + | x == c'WLC_KEY_STATE_PRESSED = KeyPressed + + toPrimitive KeyReleased = WlcKeyState c'WLC_KEY_STATE_RELEASED + toPrimitive KeyPressed = WlcKeyState c'WLC_KEY_STATE_PRESSED + +data ButtonState = ButtonReleased | ButtonPressed deriving (Eq, Show) + +instance Primitive WlcButtonState ButtonState where + fromPrimitive (WlcButtonState x) + | x == c'WLC_BUTTON_STATE_RELEASED = ButtonReleased + | x == c'WLC_BUTTON_STATE_PRESSED = ButtonPressed + + toPrimitive ButtonReleased = WlcButtonState c'WLC_BUTTON_STATE_RELEASED + toPrimitive ButtonPressed = WlcButtonState c'WLC_BUTTON_STATE_PRESSED + +data ScrollAxis = AxisVertical | AxisHorizontal deriving (Eq, Show) + +instance Primitive WlcScrollAxisBit ScrollAxis where + fromPrimitive (WlcScrollAxisBit x) + | x == c'WLC_SCROLL_AXIS_VERTICAL = AxisVertical + | x == c'WLC_SCROLL_AXIS_HORIZONTAL = AxisHorizontal + + toPrimitive AxisVertical = WlcScrollAxisBit c'WLC_SCROLL_AXIS_VERTICAL + toPrimitive AxisHorizontal = WlcScrollAxisBit c'WLC_SCROLL_AXIS_HORIZONTAL + +data TouchType = TouchDown + | TouchUp + | TouchMotion + | TouchFrame + | TouchCancel deriving (Eq, Show) + +instance Primitive WlcTouchType TouchType where + fromPrimitive (WlcTouchType x) + | x == c'WLC_TOUCH_DOWN = TouchDown + | x == c'WLC_TOUCH_UP = TouchUp + | x == c'WLC_TOUCH_MOTION = TouchMotion + | x == c'WLC_TOUCH_FRAME = TouchFrame + | x == c'WLC_TOUCH_CANCEL = TouchCancel + + toPrimitive TouchDown = WlcTouchType c'WLC_TOUCH_DOWN + toPrimitive TouchUp = WlcTouchType c'WLC_TOUCH_UP + toPrimitive TouchMotion = WlcTouchType c'WLC_TOUCH_MOTION + toPrimitive TouchFrame = WlcTouchType c'WLC_TOUCH_FRAME + toPrimitive TouchCancel = WlcTouchType c'WLC_TOUCH_CANCEL + +data Modifiers = Modifiers { leds :: Led, mods :: Modifier } + +instance Primitive C'wlc_modifiers Modifiers where + fromPrimitive C'wlc_modifiers { c'wlc_modifiers'leds = leds, c'wlc_modifiers'mods = mods } = + Modifiers { leds = fromPrimitive $ WlcLedBit leds, mods = fromPrimitive $ WlcModifierBit mods } + toPrimitive Modifiers { leds = leds, mods = mods } = + C'wlc_modifiers { + c'wlc_modifiers'leds = getLedBit $ toPrimitive leds, + c'wlc_modifiers'mods = getModifierBit $ toPrimitive mods } + +newtype Output = Output { getOutputHandle :: C'wlc_handle } +newtype View = View { getViewHandle :: C'wlc_handle } + +tryGetView :: C'wlc_handle -> Maybe View +tryGetView 0 = Nothing +tryGetView x = Just $ View x + +tryGetOutput :: C'wlc_handle -> Maybe Output +tryGetOutput 0 = Nothing +tryGetOutput x = Just $ Output x + +data Callback = OutputCreated (Output -> IO Bool) + | OutputDestroyed (Output -> IO ()) + | OutputFocus (Output -> Bool -> IO ()) + | OutputResolution (Output -> Size -> Size -> IO ()) + | OutputRenderPre (Output -> IO ()) + | OutputRenderPost (Output -> IO ()) + + | ViewCreated (View -> IO Bool) + | ViewDestroyed (View -> IO ()) + | ViewFocus (View -> Bool -> IO ()) + | ViewMoveToOutput (View -> Output -> Output -> IO ()) + | ViewRequestGeometry (View -> Geometry -> IO ()) + | ViewRequestState (View -> ViewState -> Bool -> IO ()) + | ViewRequestMove (View -> Point -> IO ()) + | ViewRequestResize (View -> ResizeEdge -> Point -> IO ()) + | ViewRenderPre (View -> IO ()) + | ViewRenderPost (View -> IO ()) + + | KeyboardKey (Maybe View -> Int -> Modifiers -> Int -> KeyState -> IO Bool) + | PointerButton (Maybe View -> Int -> Modifiers -> Int -> ButtonState -> Point -> IO Bool) + | PointerScroll (Maybe View -> Int -> Modifiers -> ScrollAxis -> Double -> IO Bool) + | PointerMotion (Maybe View -> Int -> Point -> IO Bool) + | Touch (Maybe View -> Int -> Modifiers -> TouchType -> Int -> Point -> IO Bool) + + | CompositorReady (IO ()) + | CompositorTerminate (IO ()) + +apply3 :: (e -> a) -> (f -> b) -> (g -> c) -> (a -> b -> c -> d) -> (e -> f -> g -> d) +apply3 a1 a2 a3 fn e f g = fn (a1 e) (a2 f) (a3 g) + +dispatchEvent :: Callback -> IO () +dispatchEvent (OutputCreated cb) = mk'output_created_cb (cb . Output) >>= c'wlc_set_output_created_cb +dispatchEvent (OutputDestroyed cb) = mk'output_destroyed_cb (cb . Output) >>= c'wlc_set_output_destroyed_cb +dispatchEvent (OutputFocus cb) = mk'output_focus_cb (cb . Output) >>= c'wlc_set_output_focus_cb +dispatchEvent (OutputResolution cb) = mk'output_resolution_cb (\output fromPtr toPtr -> do + Just from <- fromPrimitivePtr fromPtr + Just to <- fromPrimitivePtr toPtr + cb (Output output) from to) >>= c'wlc_set_output_resolution_cb +dispatchEvent (OutputRenderPre cb) = mk'output_render_pre_cb (cb . Output) >>= c'wlc_set_output_render_pre_cb +dispatchEvent (OutputRenderPost cb) = mk'output_render_post_cb (cb . Output) >>= c'wlc_set_output_render_post_cb + +dispatchEvent (ViewCreated cb) = mk'view_created_cb (cb . View) >>= c'wlc_set_view_created_cb +dispatchEvent (ViewDestroyed cb) = mk'view_destroyed_cb (cb . View) >>= c'wlc_set_view_destroyed_cb +dispatchEvent (ViewFocus cb) = mk'view_focus_cb (cb . View) >>= c'wlc_set_view_focus_cb +dispatchEvent (ViewMoveToOutput cb) = + mk'view_move_to_output_cb (apply3 View Output Output cb) >>= c'wlc_set_view_move_to_output_cb +dispatchEvent (ViewRequestGeometry cb) = mk'view_request_geometry_cb (\view geometryPtr -> do + Just geometry <- fromPrimitivePtr geometryPtr + cb (View view) geometry) >>= c'wlc_set_view_request_geometry_cb +dispatchEvent (ViewRequestState cb) = mk'view_request_state_cb (\view statptr toggle -> + cb (View view) (fromPrimitive $ WlcViewStateBit statptr) toggle) >>= c'wlc_set_view_request_state_cb +dispatchEvent (ViewRequestMove cb) = mk'view_request_move_cb (\view pointPtr -> do + Just point <- fromPrimitivePtr pointPtr + cb (View view) point) >>= c'wlc_set_view_request_move_cb +dispatchEvent (ViewRequestResize cb) = mk'view_request_resize_cb (\view edge pointPtr -> do + Just point <- fromPrimitivePtr pointPtr + cb (View view) (fromPrimitive $ WlcResizeEdge edge) point) >>= c'wlc_set_view_request_resize_cb +dispatchEvent (ViewRenderPre cb) = mk'view_render_pre_cb (cb . View) >>= c'wlc_set_view_render_pre_cb +dispatchEvent (ViewRenderPost cb) = mk'view_render_post_cb (cb . View) >>= c'wlc_set_view_render_post_cb + +dispatchEvent (KeyboardKey cb) = mk'keyboard_key_cb (\view time modifiersPtr key keyState -> do + Just modifier <- fromPrimitivePtr modifiersPtr + let keyst = fromPrimitive $ WlcKeyState keyState + cb (tryGetView view) (convert time) modifier (fromIntegral key) keyst) >>= c'wlc_set_keyboard_key_cb +dispatchEvent (PointerButton cb) = mk'pointer_button_cb (\view time modifiersPtr button buttonState pointPtr -> do + Just point <- fromPrimitivePtr pointPtr + Just modifier <- fromPrimitivePtr modifiersPtr + let buttonst = fromPrimitive $ WlcButtonState buttonState + cb (tryGetView view) (convert time) modifier (convert button) buttonst point) >>= c'wlc_set_pointer_button_cb +dispatchEvent (PointerScroll cb) = mk'pointer_scroll_cb (\view time modifiersPtr axisL ammount -> do + Just modifiers <- fromPrimitivePtr modifiersPtr + let axis = fromPrimitive $ WlcScrollAxisBit axisL + cb (tryGetView view) (convert time) modifiers axis ammount) >>= c'wlc_set_pointer_scroll_cb +dispatchEvent (PointerMotion cb) = mk'pointer_motion_cb (\view time pointPtr -> do + putStrLn $ "dispatchEvent: view=" ++ show view ++ " time=" ++ show time ++ " pointPtr=" ++ show pointPtr + Just point <- fromPrimitivePtr pointPtr + cb (tryGetView view) (convert time) point) >>= c'wlc_set_pointer_motion_cb +dispatchEvent (Touch cb) = mk'touch_cb (\view time modifiersPtr touchType slot pointPtr -> do + Just point <- fromPrimitivePtr pointPtr + Just modifiers <- fromPrimitivePtr modifiersPtr + let tt = fromPrimitive $ WlcTouchType touchType + cb (tryGetView view) (convert time) modifiers tt (convert slot) point) >>= c'wlc_set_touch_cb + +dispatchEvent (CompositorReady cb) = mk'compositor_ready_cb cb >>= c'wlc_set_compositor_ready_cb +dispatchEvent (CompositorTerminate cb) = mk'compositor_terminate_cb cb >>= c'wlc_set_compositor_terminate_cb + +stringTag :: LogType -> String +stringTag LogInfo = "INFO" +stringTag LogWarn = "WARN" +stringTag LogError = "ERROR" +stringTag LogWayland = "WAYLAND" + +logHandler :: (LogType -> String -> IO ()) -> IO () +logHandler cb = mk'log_handler_cb (\typ text -> do + str <- peekCString text + cb (fromPrimitive $ WlcLogType typ) str) >>= c'wlc_log_set_handler + +initialize :: IO Bool +initialize = c'wlc_init2 + +terminate :: IO () +terminate = c'wlc_terminate + +outputGetMask :: Output -> IO Word32 +outputGetMask (Output view) = convert <$> c'wlc_output_get_mask view + +outputSetMask :: Output -> Word32 -> IO () +outputSetMask (Output view) mask = c'wlc_output_set_mask view (convert mask) + +outputFocus :: Output -> IO () +outputFocus (Output output) = c'wlc_output_focus output + +viewFocus :: View -> IO () +viewFocus (View view) = c'wlc_view_focus view + +viewClose :: View -> IO () +viewClose (View view) = c'wlc_view_close view + +viewGetOutput :: View -> IO Output +viewGetOutput (View view) = Output <$> c'wlc_view_get_output view + +viewSetOutput :: View -> Output -> IO () +viewSetOutput (View view) (Output output) = c'wlc_view_set_output view output + +viewSendToBack :: View -> IO () +viewSendToBack (View view) = c'wlc_view_send_to_back view + +viewSendBelow :: View -> View -> IO () +viewSendBelow (View view) (View other) = c'wlc_view_send_below view other + +viewBringAbove :: View -> View -> IO () +viewBringAbove (View view) (View other) = c'wlc_view_bring_above view other + +viewBringToFront :: View -> IO () +viewBringToFront (View view) = c'wlc_view_bring_to_front view + +viewGetMask :: View -> IO Word32 +viewGetMask (View view) = convert <$> c'wlc_view_get_mask view + +viewSetMask :: View -> Word32 -> IO () +viewSetMask (View view) mask = c'wlc_view_set_mask view (convert mask) + +viewGetGeometry :: View -> IO Geometry +viewGetGeometry (View view) = do + geoPtr <- c'wlc_view_get_geometry view + Just geo <- fromPrimitivePtr geoPtr + return geo + +viewGetViewType :: View -> IO ViewType +viewGetViewType (View view) = fromPrimitive . WlcViewTypeBit <$> c'wlc_view_get_type view + +viewSetViewType :: View -> ViewType -> Bool -> IO () +viewSetViewType (View view) vt = c'wlc_view_set_type view (getViewTypeBit $ toPrimitive vt) + +viewGetViewState :: View -> IO ViewState +viewGetViewState (View view) = fromPrimitive . WlcViewStateBit <$> c'wlc_view_get_state view + +viewSetViewState :: View -> ViewState -> Bool -> IO () +viewSetViewState (View view) vs = c'wlc_view_set_state view (getViewStateBit $ toPrimitive vs) + +viewGetParent :: View -> IO (Maybe View) +viewGetParent (View view) = tryGetView <$> c'wlc_view_get_parent view + +viewSetParent :: View -> View -> IO () +viewSetParent (View view) (View other) = c'wlc_view_set_parent view other + +viewGetTitle :: View -> IO String +viewGetTitle (View view) = c'wlc_view_get_title view >>= peekCString + +viewGetClass :: View -> IO String +viewGetClass (View view) = c'wlc_view_get_class view >>= peekCString + +viewGetAppId :: View -> IO String +viewGetAppId (View view) = c'wlc_view_get_app_id view >>= peekCString + +pointerGetPosition :: IO Point +pointerGetPosition = + alloca (\point -> do + c'wlc_pointer_get_position point + Just pt <- fromPrimitivePtr point + return pt) + +pointerSetPosition :: Point -> IO () +pointerSetPosition pt = with point c'wlc_pointer_set_position + where point = toPrimitive pt + +getBackendType :: IO BackendType +getBackendType = do + backend <- c'wlc_get_backend_type + return $ fromPrimitive (WlcBackendType backend) + +exec :: String -> [String] -> IO () +exec app args = do + let fullArgs = app : args + putStrLn $ "Executing: " ++ app ++ " with " ++ show fullArgs + convertedArgs <- mapM newCString fullArgs + withCString app $ withArray0 nullPtr convertedArgs . c'wlc_exec + mapM_ free convertedArgs + +run :: IO () +run = c'wlc_run diff --git a/src/System/WLC/Geometry.hs b/src/System/WLC/Geometry.hs new file mode 100644 --- /dev/null +++ b/src/System/WLC/Geometry.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +module System.WLC.Geometry where + +import Foreign.Ptr(Ptr) +import Data.Word(Word32) +import Data.Convertible.Base +import Data.Convertible.Instances.C + +import System.WLC.Utilities +import Bindings.WLC.Geometry + + +data Point = Point { x :: Int, y :: Int } + deriving (Eq, Show, Ord) + +instance Primitive C'wlc_point Point where + fromPrimitive C'wlc_point { c'wlc_point'x = x, c'wlc_point'y = y } = Point { x = convert x, y = convert y } + toPrimitive Point { x = x, y = y } = C'wlc_point { c'wlc_point'x = convert x, c'wlc_point'y = convert y } + +data Size = Size { w :: Word32, h :: Word32 } + deriving (Eq, Show, Ord) + +instance Primitive C'wlc_size Size where + fromPrimitive C'wlc_size { c'wlc_size'w = w, c'wlc_size'h = h } = Size { w = convert w, h = convert h } + toPrimitive Size { w = w, h = h } = C'wlc_size { c'wlc_size'w = convert w, c'wlc_size'h = convert h } + +data Geometry = Geometry { origin :: Point, size :: Size } + deriving (Eq, Show, Ord) + +instance Primitive C'wlc_geometry Geometry where + fromPrimitive C'wlc_geometry { c'wlc_geometry'size = size, c'wlc_geometry'origin = origin } = + Geometry { origin = fromPrimitive origin, size = fromPrimitive size } + toPrimitive Geometry { size = size, origin = origin } = + C'wlc_geometry { c'wlc_geometry'size = toPrimitive size, c'wlc_geometry'origin = toPrimitive origin }