├── .gitignore ├── .gitmodules ├── ChangeLog.md ├── LICENSE ├── README.md ├── Setup.hs ├── cabal.project ├── cbits ├── cat.c ├── cat.h ├── signal.c └── xdg_helpers.c ├── hsroots.cabal ├── protocol ├── tablet-unstable-v2-protocol.h ├── wlr-input-inhibtor-unstable-v1-protocol.h ├── wlr-layer-shell-unstable-v1-protocol.h ├── xdg-shell-protocol.h └── xdg-shell-unstable-v6-protocol.h └── src ├── Graphics ├── Egl.hsc ├── Pixman.hsc └── Wayland │ ├── Global.hs │ ├── List.hsc │ ├── Resource.hs │ ├── Server │ └── Client.hsc │ ├── Signal.hsc │ └── WlRoots │ ├── Backend.hsc │ ├── Backend │ ├── Headless.hsc │ ├── Libinput.hsc │ ├── Multi.hs │ └── Session.hs │ ├── Box.hsc │ ├── Buffer.hsc │ ├── Compositor.hs │ ├── Cursor.hsc │ ├── DataControl.hsc │ ├── DeviceManager.hsc │ ├── Egl.hs │ ├── ExportDMABuf.hsc │ ├── GammaControl.hsc │ ├── Global.hs │ ├── IdleInhibit.hsc │ ├── Input.hs-boot │ ├── Input.hsc │ ├── Input │ ├── Buttons.hsc │ ├── Keyboard.hsc │ ├── Pointer.hsc │ ├── Tablet.hsc │ ├── TabletPad.hsc │ ├── TabletTool.hsc │ └── Touch.hsc │ ├── InputInhibitor.hsc │ ├── LinuxDMABuf.hsc │ ├── Output.hsc │ ├── OutputLayout.hsc │ ├── PrimarySelection.hsc │ ├── Render.hsc │ ├── Render │ ├── Color.hs │ ├── Gles2.hs │ └── Matrix.hs │ ├── Screenshooter.hsc │ ├── Seat.hsc │ ├── ServerDecoration.hsc │ ├── Surface.hsc │ ├── SurfaceLayers.hsc │ ├── Tabletv2.hsc │ ├── Util.hsc │ ├── Util │ └── Region.hsc │ ├── WlShell.hsc │ ├── XCursor.hsc │ ├── XCursorManager.hsc │ ├── XWayland.hsc │ ├── XdgShell.hsc │ └── XdgShellv6.hsc └── Utility.hs /.gitignore: -------------------------------------------------------------------------------- 1 | dist-newstyle 2 | dist 3 | *.swp 4 | *.swo 5 | -------------------------------------------------------------------------------- /.gitmodules: -------------------------------------------------------------------------------- 1 | [submodule "haskell-wayland"] 2 | path = haskell-wayland 3 | url = https://github.com/Ongy/haskell-wayland.git 4 | [submodule "haskell-xkbcommon"] 5 | path = haskell-xkbcommon 6 | url = https://github.com/ongy/haskell-xkbcommon 7 | [submodule "libinput"] 8 | path = libinput 9 | url = https://github.com/waymonad/libinput 10 | -------------------------------------------------------------------------------- /ChangeLog.md: -------------------------------------------------------------------------------- 1 | # Revision history for hsroots 2 | 3 | ## 0.1.0.0 -- YYYY-mm-dd 4 | 5 | * First version. Released on an unsuspecting world. 6 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # hsroots, the Haskell bindings to wlroots 2 | 3 | If you haven't seen it, [wlroots](https://github.com/swaywm/wlroots) is the compositor library created by the same people who built [sway](https://github.com/swaywm/sway) to implement a few things that weren't possible with [wlc](https://github.com/Cloudef/wlc). 4 | 5 | ### What is this: 6 | 7 | * Basic (low! level) bindings to wlroots functionality 8 | * (Re)implementation of basic examples. This is mostly to test 9 | * cabal project to track updated dependencies (I had to expose a bit of functionality, this isn't upstreamed yet). 10 | 11 | ### What this is (mostly) not [help wanted]: 12 | 13 | * Complete 14 | * well documented 15 | * Abstracting 16 | 17 | This one is semi-intentional. This library is intended to expose pointers as they are, so it can be used with other middlewares etc. 18 | * In a good functional style 19 | 20 | ## Why does this exist? 21 | 22 | I mainly created this to support [my own endavours](https://github.com/Ongy/waymonad). 23 | This implies that I will somewhat selectivly add to this as I need it in any project based on this. 24 | 25 | Should you be interested in using this and feel like there's a feature missing, I will always appreciate PRs, and will aim to implemented feature requests in a timely manner. 26 | 27 | ### Build instructions 28 | 29 | * Install `wlroots` with the instructions provided in their Readme 30 | * `git clone --recursive https://github.com/swaywm/hsroots` 31 | * `cd hsroots` 32 | * `cabal new-build` 33 | 34 | This should download all dependencies needed for hsroots and build it together 35 | with the examples provided in this repository. 36 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: ./ haskell-wayland/ haskell-xkbcommon 2 | 3 | -------------------------------------------------------------------------------- /cbits/cat.h: -------------------------------------------------------------------------------- 1 | #ifndef _CAT_H 2 | #define _CAT_H 3 | 4 | struct gimp_texture { 5 | unsigned int width; 6 | unsigned int height; 7 | unsigned int bytes_per_pixel; /* 2:RGB16, 3:RGB, 4:RGBA */ 8 | unsigned char pixel_data[128 * 128 * 4 + 1]; 9 | }; 10 | 11 | extern const struct gimp_texture cat_tex; 12 | 13 | #endif 14 | -------------------------------------------------------------------------------- /cbits/signal.c: -------------------------------------------------------------------------------- 1 | #include 2 | 3 | void 4 | c_signal_add(struct wl_signal *signal, struct wl_listener *listener) 5 | { 6 | wl_signal_add(signal, listener); 7 | } 8 | -------------------------------------------------------------------------------- /cbits/xdg_helpers.c: -------------------------------------------------------------------------------- 1 | #define WLR_USE_UNSTABLE 2 | #include 3 | #include 4 | #include 5 | 6 | void wlr_xdg_positioner_v6_get_geometry_c(struct wlr_xdg_positioner_v6 *positioner, 7 | struct wlr_box *box) 8 | { 9 | *box = wlr_xdg_positioner_v6_get_geometry(positioner); 10 | } 11 | 12 | //void wlr_xdg_positioner_get_geometry_c(struct wlr_xdg_positioner *positioner, 13 | // struct wlr_box *box) 14 | //{ 15 | // *box = wlr_xdg_positioner_get_geometry(positioner); 16 | //} 17 | -------------------------------------------------------------------------------- /hsroots.cabal: -------------------------------------------------------------------------------- 1 | -- Initial hsroots.cabal generated by cabal init. For further 2 | -- documentation, see http://haskell.org/cabal/users-guide/ 3 | 4 | -- The name of the package. 5 | name: hsroots 6 | 7 | -- The package version. See the Haskell package versioning policy (PVP) 8 | -- for standards guiding when and how versions should be incremented. 9 | -- https://wiki.haskell.org/Package_versioning_policy 10 | -- PVP summary: +-+------- breaking API changes 11 | -- | | +----- non-breaking API additions 12 | -- | | | +--- code changes with no API change 13 | version: 0.1.0.0 14 | 15 | -- A short (one-line) description of the package. 16 | synopsis: A small simple wrapper around wolroots 17 | 18 | -- A longer description of the package. 19 | -- description: 20 | 21 | -- The license under which the package is released. 22 | license: LGPL-2.1 23 | 24 | -- The file containing the license text. 25 | license-file: LICENSE 26 | 27 | -- The package author(s). 28 | author: Markus Ongyerth 29 | 30 | -- An email address to which users can send suggestions, bug reports, and 31 | -- patches. 32 | maintainer: ongy@ongy.net 33 | 34 | -- A copyright notice. 35 | -- copyright: 36 | 37 | category: Graphics 38 | 39 | build-type: Simple 40 | 41 | -- Extra files to be distributed with the package, such as examples or a 42 | -- README. 43 | extra-source-files: ChangeLog.md 44 | 45 | -- Constraint on the version of Cabal needed to build this package. 46 | cabal-version: >=1.10 47 | 48 | 49 | library 50 | -- Modules exported by the library. 51 | exposed-modules: Graphics.Egl 52 | exposed-modules: Graphics.Pixman 53 | exposed-modules: Graphics.Wayland.Global 54 | exposed-modules: Graphics.Wayland.List 55 | exposed-modules: Graphics.Wayland.Resource 56 | exposed-modules: Graphics.Wayland.Server.Client 57 | exposed-modules: Graphics.Wayland.Signal 58 | exposed-modules: Graphics.Wayland.WlRoots.Backend 59 | exposed-modules: Graphics.Wayland.WlRoots.Backend.Headless 60 | exposed-modules: Graphics.Wayland.WlRoots.Backend.Libinput 61 | exposed-modules: Graphics.Wayland.WlRoots.Backend.Multi 62 | exposed-modules: Graphics.Wayland.WlRoots.Backend.Session 63 | exposed-modules: Graphics.Wayland.WlRoots.Box 64 | exposed-modules: Graphics.Wayland.WlRoots.Buffer 65 | exposed-modules: Graphics.Wayland.WlRoots.Compositor 66 | exposed-modules: Graphics.Wayland.WlRoots.Cursor 67 | exposed-modules: Graphics.Wayland.WlRoots.DataControl 68 | exposed-modules: Graphics.Wayland.WlRoots.DeviceManager 69 | exposed-modules: Graphics.Wayland.WlRoots.ExportDMABuf 70 | exposed-modules: Graphics.Wayland.WlRoots.Egl 71 | exposed-modules: Graphics.Wayland.WlRoots.GammaControl 72 | exposed-modules: Graphics.Wayland.WlRoots.Global 73 | exposed-modules: Graphics.Wayland.WlRoots.IdleInhibit 74 | exposed-modules: Graphics.Wayland.WlRoots.Input 75 | exposed-modules: Graphics.Wayland.WlRoots.Input.Buttons 76 | exposed-modules: Graphics.Wayland.WlRoots.Input.Keyboard 77 | exposed-modules: Graphics.Wayland.WlRoots.Input.Pointer 78 | exposed-modules: Graphics.Wayland.WlRoots.Input.Tablet 79 | exposed-modules: Graphics.Wayland.WlRoots.Input.TabletPad 80 | exposed-modules: Graphics.Wayland.WlRoots.Input.TabletTool 81 | exposed-modules: Graphics.Wayland.WlRoots.Input.Touch 82 | exposed-modules: Graphics.Wayland.WlRoots.InputInhibitor 83 | exposed-modules: Graphics.Wayland.WlRoots.LinuxDMABuf 84 | exposed-modules: Graphics.Wayland.WlRoots.Output 85 | exposed-modules: Graphics.Wayland.WlRoots.OutputLayout 86 | --exposed-modules: Graphics.Wayland.WlRoots.PrimarySelection 87 | exposed-modules: Graphics.Wayland.WlRoots.Render 88 | exposed-modules: Graphics.Wayland.WlRoots.Render.Color 89 | exposed-modules: Graphics.Wayland.WlRoots.Render.Gles2 90 | exposed-modules: Graphics.Wayland.WlRoots.Render.Matrix 91 | exposed-modules: Graphics.Wayland.WlRoots.Screenshooter 92 | exposed-modules: Graphics.Wayland.WlRoots.Seat 93 | exposed-modules: Graphics.Wayland.WlRoots.ServerDecoration 94 | exposed-modules: Graphics.Wayland.WlRoots.Surface 95 | exposed-modules: Graphics.Wayland.WlRoots.SurfaceLayers 96 | exposed-modules: Graphics.Wayland.WlRoots.Tabletv2 97 | exposed-modules: Graphics.Wayland.WlRoots.Util 98 | exposed-modules: Graphics.Wayland.WlRoots.Util.Region 99 | exposed-modules: Graphics.Wayland.WlRoots.WlShell 100 | exposed-modules: Graphics.Wayland.WlRoots.XCursor 101 | exposed-modules: Graphics.Wayland.WlRoots.XCursorManager 102 | exposed-modules: Graphics.Wayland.WlRoots.XWayland 103 | exposed-modules: Graphics.Wayland.WlRoots.XdgShell 104 | exposed-modules: Graphics.Wayland.WlRoots.XdgShellv6 105 | 106 | -- Modules included in this library but not exported. 107 | other-modules: Utility 108 | 109 | -- LANGUAGE extensions used by modules in this package. 110 | -- other-extensions: 111 | 112 | -- Other library packages from which modules are imported. 113 | build-depends: base >=4.7 && <5, 114 | composition >= 1.0.2 && < 1.1, 115 | hayland, xkbcommon, bytestring, text, 116 | libinput, unix 117 | 118 | 119 | -- Directories containing source files. 120 | hs-source-dirs: src 121 | 122 | -- Base language which the package is written in. 123 | default-language: Haskell2010 124 | ghc-options: -Wall -Werror 125 | 126 | Extra-libraries: wayland-server 127 | Extra-libraries: input 128 | 129 | c-sources: cbits/signal.c 130 | c-sources: cbits/xdg_helpers.c 131 | PkgConfig-Depends: pixman-1 132 | PkgConfig-Depends: wlroots 133 | include-dirs: protocol 134 | 135 | --build-depends: dump-core 136 | --ghc-options: -fplugin=DumpCore -fplugin-opt DumpCore:core-html 137 | --ghc-options: -O2 138 | -------------------------------------------------------------------------------- /protocol/wlr-input-inhibtor-unstable-v1-protocol.h: -------------------------------------------------------------------------------- 1 | /* Generated by wayland-scanner 1.14.0 */ 2 | 3 | #ifndef WLR_INPUT_INHIBIT_UNSTABLE_V1_CLIENT_PROTOCOL_H 4 | #define WLR_INPUT_INHIBIT_UNSTABLE_V1_CLIENT_PROTOCOL_H 5 | 6 | #include 7 | #include 8 | #include "wayland-client.h" 9 | 10 | #ifdef __cplusplus 11 | extern "C" { 12 | #endif 13 | 14 | /** 15 | * @page page_wlr_input_inhibit_unstable_v1 The wlr_input_inhibit_unstable_v1 protocol 16 | * @section page_ifaces_wlr_input_inhibit_unstable_v1 Interfaces 17 | * - @subpage page_iface_zwlr_input_inhibit_manager_v1 - inhibits input events to other clients 18 | * - @subpage page_iface_zwlr_input_inhibitor_v1 - inhibits input to other clients 19 | * @section page_copyright_wlr_input_inhibit_unstable_v1 Copyright 20 | * 
 21 |  *
 22 |  * Copyright © 2018 Drew DeVault
 23 |  *
 24 |  * Permission to use, copy, modify, distribute, and sell this
 25 |  * software and its documentation for any purpose is hereby granted
 26 |  * without fee, provided that the above copyright notice appear in
 27 |  * all copies and that both that copyright notice and this permission
 28 |  * notice appear in supporting documentation, and that the name of
 29 |  * the copyright holders not be used in advertising or publicity
 30 |  * pertaining to distribution of the software without specific,
 31 |  * written prior permission.  The copyright holders make no
 32 |  * representations about the suitability of this software for any
 33 |  * purpose.  It is provided "as is" without express or implied
 34 |  * warranty.
 35 |  *
 36 |  * THE COPYRIGHT HOLDERS DISCLAIM ALL WARRANTIES WITH REGARD TO THIS
 37 |  * SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND
 38 |  * FITNESS, IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY
 39 |  * SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
 40 |  * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN
 41 |  * AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION,
 42 |  * ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF
 43 |  * THIS SOFTWARE.
 44 |  *
45 | */ 46 | struct zwlr_input_inhibit_manager_v1; 47 | struct zwlr_input_inhibitor_v1; 48 | 49 | /** 50 | * @page page_iface_zwlr_input_inhibit_manager_v1 zwlr_input_inhibit_manager_v1 51 | * @section page_iface_zwlr_input_inhibit_manager_v1_desc Description 52 | * 53 | * Clients can use this interface to prevent input events from being sent to 54 | * any surfaces but its own, which is useful for example in lock screen 55 | * software. It is assumed that access to this interface will be locked down 56 | * to whitelisted clients by the compositor. 57 | * @section page_iface_zwlr_input_inhibit_manager_v1_api API 58 | * See @ref iface_zwlr_input_inhibit_manager_v1. 59 | */ 60 | /** 61 | * @defgroup iface_zwlr_input_inhibit_manager_v1 The zwlr_input_inhibit_manager_v1 interface 62 | * 63 | * Clients can use this interface to prevent input events from being sent to 64 | * any surfaces but its own, which is useful for example in lock screen 65 | * software. It is assumed that access to this interface will be locked down 66 | * to whitelisted clients by the compositor. 67 | */ 68 | extern const struct wl_interface zwlr_input_inhibit_manager_v1_interface; 69 | /** 70 | * @page page_iface_zwlr_input_inhibitor_v1 zwlr_input_inhibitor_v1 71 | * @section page_iface_zwlr_input_inhibitor_v1_desc Description 72 | * 73 | * While this resource exists, input to clients other than the owner of the 74 | * inhibitor resource will not receive input events. The client that owns 75 | * this resource will receive all input events normally. The compositor will 76 | * also disable all of its own input processing (such as keyboard shortcuts) 77 | * while the inhibitor is active. 78 | * 79 | * The compositor may continue to send input events to selected clients, 80 | * such as an on-screen keyboard (via the input-method protocol). 81 | * @section page_iface_zwlr_input_inhibitor_v1_api API 82 | * See @ref iface_zwlr_input_inhibitor_v1. 83 | */ 84 | /** 85 | * @defgroup iface_zwlr_input_inhibitor_v1 The zwlr_input_inhibitor_v1 interface 86 | * 87 | * While this resource exists, input to clients other than the owner of the 88 | * inhibitor resource will not receive input events. The client that owns 89 | * this resource will receive all input events normally. The compositor will 90 | * also disable all of its own input processing (such as keyboard shortcuts) 91 | * while the inhibitor is active. 92 | * 93 | * The compositor may continue to send input events to selected clients, 94 | * such as an on-screen keyboard (via the input-method protocol). 95 | */ 96 | extern const struct wl_interface zwlr_input_inhibitor_v1_interface; 97 | 98 | #ifndef ZWLR_INPUT_INHIBIT_MANAGER_V1_ERROR_ENUM 99 | #define ZWLR_INPUT_INHIBIT_MANAGER_V1_ERROR_ENUM 100 | enum zwlr_input_inhibit_manager_v1_error { 101 | /** 102 | * an input inhibitor is already in use on the compositor 103 | */ 104 | ZWLR_INPUT_INHIBIT_MANAGER_V1_ERROR_ALREADY_INHIBITED = 0, 105 | }; 106 | #endif /* ZWLR_INPUT_INHIBIT_MANAGER_V1_ERROR_ENUM */ 107 | 108 | #define ZWLR_INPUT_INHIBIT_MANAGER_V1_GET_INHIBITOR 0 109 | 110 | 111 | /** 112 | * @ingroup iface_zwlr_input_inhibit_manager_v1 113 | */ 114 | #define ZWLR_INPUT_INHIBIT_MANAGER_V1_GET_INHIBITOR_SINCE_VERSION 1 115 | 116 | /** @ingroup iface_zwlr_input_inhibit_manager_v1 */ 117 | static inline void 118 | zwlr_input_inhibit_manager_v1_set_user_data(struct zwlr_input_inhibit_manager_v1 *zwlr_input_inhibit_manager_v1, void *user_data) 119 | { 120 | wl_proxy_set_user_data((struct wl_proxy *) zwlr_input_inhibit_manager_v1, user_data); 121 | } 122 | 123 | /** @ingroup iface_zwlr_input_inhibit_manager_v1 */ 124 | static inline void * 125 | zwlr_input_inhibit_manager_v1_get_user_data(struct zwlr_input_inhibit_manager_v1 *zwlr_input_inhibit_manager_v1) 126 | { 127 | return wl_proxy_get_user_data((struct wl_proxy *) zwlr_input_inhibit_manager_v1); 128 | } 129 | 130 | static inline uint32_t 131 | zwlr_input_inhibit_manager_v1_get_version(struct zwlr_input_inhibit_manager_v1 *zwlr_input_inhibit_manager_v1) 132 | { 133 | return wl_proxy_get_version((struct wl_proxy *) zwlr_input_inhibit_manager_v1); 134 | } 135 | 136 | /** @ingroup iface_zwlr_input_inhibit_manager_v1 */ 137 | static inline void 138 | zwlr_input_inhibit_manager_v1_destroy(struct zwlr_input_inhibit_manager_v1 *zwlr_input_inhibit_manager_v1) 139 | { 140 | wl_proxy_destroy((struct wl_proxy *) zwlr_input_inhibit_manager_v1); 141 | } 142 | 143 | /** 144 | * @ingroup iface_zwlr_input_inhibit_manager_v1 145 | * 146 | * Activates the input inhibitor. As long as the inhibitor is active, the 147 | * compositor will not send input events to other clients. 148 | */ 149 | static inline struct zwlr_input_inhibitor_v1 * 150 | zwlr_input_inhibit_manager_v1_get_inhibitor(struct zwlr_input_inhibit_manager_v1 *zwlr_input_inhibit_manager_v1) 151 | { 152 | struct wl_proxy *id; 153 | 154 | id = wl_proxy_marshal_constructor((struct wl_proxy *) zwlr_input_inhibit_manager_v1, 155 | ZWLR_INPUT_INHIBIT_MANAGER_V1_GET_INHIBITOR, &zwlr_input_inhibitor_v1_interface, NULL); 156 | 157 | return (struct zwlr_input_inhibitor_v1 *) id; 158 | } 159 | 160 | #define ZWLR_INPUT_INHIBITOR_V1_DESTROY 0 161 | 162 | 163 | /** 164 | * @ingroup iface_zwlr_input_inhibitor_v1 165 | */ 166 | #define ZWLR_INPUT_INHIBITOR_V1_DESTROY_SINCE_VERSION 1 167 | 168 | /** @ingroup iface_zwlr_input_inhibitor_v1 */ 169 | static inline void 170 | zwlr_input_inhibitor_v1_set_user_data(struct zwlr_input_inhibitor_v1 *zwlr_input_inhibitor_v1, void *user_data) 171 | { 172 | wl_proxy_set_user_data((struct wl_proxy *) zwlr_input_inhibitor_v1, user_data); 173 | } 174 | 175 | /** @ingroup iface_zwlr_input_inhibitor_v1 */ 176 | static inline void * 177 | zwlr_input_inhibitor_v1_get_user_data(struct zwlr_input_inhibitor_v1 *zwlr_input_inhibitor_v1) 178 | { 179 | return wl_proxy_get_user_data((struct wl_proxy *) zwlr_input_inhibitor_v1); 180 | } 181 | 182 | static inline uint32_t 183 | zwlr_input_inhibitor_v1_get_version(struct zwlr_input_inhibitor_v1 *zwlr_input_inhibitor_v1) 184 | { 185 | return wl_proxy_get_version((struct wl_proxy *) zwlr_input_inhibitor_v1); 186 | } 187 | 188 | /** 189 | * @ingroup iface_zwlr_input_inhibitor_v1 190 | * 191 | * Destroy the inhibitor and allow other clients to receive input. 192 | */ 193 | static inline void 194 | zwlr_input_inhibitor_v1_destroy(struct zwlr_input_inhibitor_v1 *zwlr_input_inhibitor_v1) 195 | { 196 | wl_proxy_marshal((struct wl_proxy *) zwlr_input_inhibitor_v1, 197 | ZWLR_INPUT_INHIBITOR_V1_DESTROY); 198 | 199 | wl_proxy_destroy((struct wl_proxy *) zwlr_input_inhibitor_v1); 200 | } 201 | 202 | #ifdef __cplusplus 203 | } 204 | #endif 205 | 206 | #endif 207 | -------------------------------------------------------------------------------- /src/Graphics/Egl.hsc: -------------------------------------------------------------------------------- 1 | module Graphics.Egl 2 | ( Platform(..) 3 | , getPlatform 4 | ) 5 | where 6 | 7 | #include 8 | #include 9 | 10 | data Platform 11 | = DeviceExt 12 | | AndroidKhr 13 | | X11Ext 14 | | X11Khr 15 | | X11ScreenExt 16 | | X11ScreenKhr 17 | | GBMKhr 18 | | GBMMesa 19 | | WaylandExt 20 | | WaylandKhr 21 | | SurfacelessMesa 22 | 23 | getPlatform :: Num a => Platform -> a 24 | getPlatform DeviceExt = #{const EGL_PLATFORM_DEVICE_EXT} 25 | getPlatform AndroidKhr = #{const EGL_PLATFORM_ANDROID_KHR} 26 | getPlatform X11Ext = #{const EGL_PLATFORM_X11_EXT} 27 | getPlatform X11Khr = #{const EGL_PLATFORM_X11_KHR} 28 | getPlatform X11ScreenExt = #{const EGL_PLATFORM_X11_SCREEN_EXT} 29 | getPlatform X11ScreenKhr = #{const EGL_PLATFORM_X11_SCREEN_KHR} 30 | getPlatform GBMKhr = #{const EGL_PLATFORM_GBM_KHR} 31 | getPlatform GBMMesa = #{const EGL_PLATFORM_GBM_MESA} 32 | getPlatform WaylandExt = #{const EGL_PLATFORM_WAYLAND_EXT} 33 | getPlatform WaylandKhr = #{const EGL_PLATFORM_WAYLAND_KHR} 34 | getPlatform SurfacelessMesa = #{const EGL_PLATFORM_SURFACELESS_MESA} 35 | -------------------------------------------------------------------------------- /src/Graphics/Pixman.hsc: -------------------------------------------------------------------------------- 1 | -- This should probably live in another module in future 2 | module Graphics.Pixman 3 | ( pixmanRegionExtents 4 | , PixmanRegion32 (..) 5 | , PixmanBox32 (..) 6 | , pixmanRegionNotEmpty 7 | , pixmanRegionTranslate 8 | , withRegionCopy 9 | , withRegion 10 | , pixmanRegionBoxes 11 | , withRegion32 12 | 13 | , allocateRegion 14 | , resetRegion 15 | , pixmanRegionUnion 16 | , pixmanRegionIntersect 17 | , boxToWlrBox 18 | , copyRegion 19 | , pixmanRegionSubtract 20 | , withBoxRegion 21 | ) 22 | where 23 | 24 | #include 25 | 26 | import Control.Exception (bracket_) 27 | import Data.Int (Int32) 28 | import Foreign.C.Types (CInt (..), CUInt (..)) 29 | import Foreign.Concurrent (newForeignPtr) 30 | import Foreign.ForeignPtr (ForeignPtr, withForeignPtr) 31 | import Foreign.Ptr (Ptr) 32 | import Foreign.Storable (Storable(..)) 33 | import Foreign.Marshal.Alloc (allocaBytes, alloca, mallocBytes, free) 34 | import Foreign.Marshal.Array (peekArray) 35 | 36 | import Graphics.Wayland.WlRoots.Box (WlrBox (..)) 37 | 38 | data PixmanRegion32 39 | = PixmanRegion32 { unPR32 :: Ptr PixmanRegion32} 40 | | PixmanRegion32A { unPR32A :: ForeignPtr PixmanRegion32 } 41 | 42 | withRegion32 :: PixmanRegion32 -> (Ptr PixmanRegion32 -> IO a) -> IO a 43 | withRegion32 (PixmanRegion32 r) act = act r 44 | withRegion32 (PixmanRegion32A fptr) act = withForeignPtr fptr $ act 45 | 46 | boxToWlrBox :: PixmanBox32 -> WlrBox 47 | boxToWlrBox (PixmanBox32 x1 y1 x2 y2) = WlrBox 48 | (fromIntegral x1) 49 | (fromIntegral y1) 50 | (fromIntegral $ x2 - x1) 51 | (fromIntegral $ y2 - y1) 52 | 53 | withBoxRegion :: WlrBox -> (PixmanRegion32 -> IO a) -> IO a 54 | withBoxRegion box fun = withRegion $ \region -> do 55 | resetRegion region $ Just box 56 | fun region 57 | 58 | data PixmanBox32 = PixmanBox32 59 | { pBoxX1 :: Int32 60 | , pBoxY1 :: Int32 61 | , pBoxX2 :: Int32 62 | , pBoxY2 :: Int32 63 | } deriving (Show, Eq) 64 | 65 | instance Storable PixmanBox32 where 66 | sizeOf _ = #{size struct pixman_box32} 67 | alignment _ = #{alignment struct pixman_box32} 68 | peek ptr = PixmanBox32 69 | <$> #{peek struct pixman_box32, x1} ptr 70 | <*> #{peek struct pixman_box32, y1} ptr 71 | <*> #{peek struct pixman_box32, x2} ptr 72 | <*> #{peek struct pixman_box32, y2} ptr 73 | poke ptr (PixmanBox32 x1 y1 x2 y2) = do 74 | #{poke struct pixman_box32, x1} ptr x1 75 | #{poke struct pixman_box32, y1} ptr y1 76 | #{poke struct pixman_box32, x2} ptr x2 77 | #{poke struct pixman_box32, y2} ptr y2 78 | 79 | foreign import ccall unsafe "pixman_region32_extents" c_32_extends :: Ptr PixmanRegion32 -> IO (Ptr PixmanBox32) 80 | 81 | pixmanRegionExtents :: PixmanRegion32 -> IO PixmanBox32 82 | pixmanRegionExtents region = peek =<< withRegion32 region c_32_extends 83 | 84 | foreign import ccall unsafe "pixman_region32_not_empty" c_32_not_empty :: Ptr PixmanRegion32 -> IO Bool 85 | 86 | pixmanRegionNotEmpty :: PixmanRegion32 -> IO Bool 87 | pixmanRegionNotEmpty = flip withRegion32 c_32_not_empty 88 | 89 | foreign import ccall unsafe "pixman_region32_translate" c_32_translate :: Ptr PixmanRegion32 -> CInt -> CInt -> IO () 90 | 91 | pixmanRegionTranslate :: PixmanRegion32 -> Int -> Int -> IO () 92 | pixmanRegionTranslate region x y = withRegion32 region $ \ptr -> 93 | c_32_translate ptr (fromIntegral x) (fromIntegral y) 94 | 95 | foreign import ccall unsafe "pixman_region32_copy" c_32_copy :: Ptr PixmanRegion32 -> Ptr PixmanRegion32 -> IO () 96 | 97 | withRegionCopy :: PixmanRegion32 -> (PixmanRegion32 -> IO a) -> IO a 98 | withRegionCopy orig act = withRegion32 orig $ \original -> withRegion $ \copy -> do 99 | c_32_copy (unPR32 copy) original 100 | act $ copy 101 | 102 | copyRegion :: PixmanRegion32 -> PixmanRegion32 -> IO () 103 | copyRegion dst src = withRegion32 dst $ \dstPtr -> 104 | withRegion32 src $ \srcPtr -> 105 | c_32_copy dstPtr srcPtr 106 | 107 | foreign import ccall unsafe "pixman_region32_init" c_32_init :: Ptr PixmanRegion32 -> IO () 108 | foreign import ccall unsafe "pixman_region32_init_rect" c_32_init_rect :: Ptr PixmanRegion32 -> CInt -> CInt -> CUInt -> CUInt -> IO () 109 | foreign import ccall unsafe "pixman_region32_clear" c_32_clear :: Ptr PixmanRegion32 -> IO () 110 | foreign import ccall unsafe "pixman_region32_fini" c_32_fini :: Ptr PixmanRegion32 -> IO () 111 | 112 | withRegion :: (PixmanRegion32 -> IO a) -> IO a 113 | withRegion act = allocaBytes #{size struct pixman_region32} $ \reg -> bracket_ 114 | (c_32_init reg) 115 | (c_32_fini reg) 116 | (act $ PixmanRegion32 reg) 117 | 118 | allocateRegion :: IO PixmanRegion32 119 | allocateRegion = do 120 | ret <- mallocBytes #{size struct pixman_region32} 121 | c_32_init ret 122 | fptr <- newForeignPtr ret (freeRegion ret) 123 | pure $ PixmanRegion32A fptr 124 | 125 | freeRegion :: Ptr PixmanRegion32 -> IO () 126 | freeRegion ptr = do 127 | c_32_fini ptr 128 | free ptr 129 | 130 | resetRegion :: PixmanRegion32 -> Maybe WlrBox -> IO () 131 | resetRegion reg box = withRegion32 reg $ \ptr -> do 132 | c_32_clear ptr 133 | case box of 134 | Nothing -> c_32_init ptr 135 | Just (WlrBox x y w h) -> 136 | c_32_init_rect ptr 137 | (fromIntegral x) 138 | (fromIntegral y) 139 | (fromIntegral w) 140 | (fromIntegral h) 141 | 142 | foreign import ccall unsafe "pixman_region32_rectangles" c_32_rectangles :: Ptr PixmanRegion32 -> Ptr CInt -> IO (Ptr PixmanBox32) 143 | 144 | pixmanRegionBoxes :: PixmanRegion32 -> IO [PixmanBox32] 145 | pixmanRegionBoxes region = alloca $ \nPtr -> withRegion32 region $ \reg -> do 146 | ret <- c_32_rectangles reg nPtr 147 | num <- peek nPtr 148 | peekArray (fromIntegral num) ret 149 | 150 | foreign import ccall unsafe "pixman_region32_union" c_32_union :: Ptr PixmanRegion32 -> Ptr PixmanRegion32 -> Ptr PixmanRegion32 -> IO () 151 | 152 | pixmanRegionUnion :: PixmanRegion32 -> PixmanRegion32 -> IO () 153 | pixmanRegionUnion dst src = withRegion32 dst $ \dstPtr -> 154 | withRegion32 src $ \srcPtr -> 155 | c_32_union dstPtr dstPtr srcPtr 156 | 157 | foreign import ccall unsafe "pixman_region32_intersect" c_32_intersect :: Ptr PixmanRegion32 -> Ptr PixmanRegion32 -> Ptr PixmanRegion32 -> IO () 158 | 159 | pixmanRegionIntersect :: PixmanRegion32 -> PixmanRegion32 -> IO () 160 | pixmanRegionIntersect dst src = withRegion32 dst $ \dstPtr -> 161 | withRegion32 src $ \srcPtr -> 162 | c_32_intersect dstPtr dstPtr srcPtr 163 | 164 | foreign import ccall unsafe "pixman_region32_subtract" c_32_subtract :: Ptr PixmanRegion32 -> Ptr PixmanRegion32 -> Ptr PixmanRegion32 -> IO () 165 | 166 | pixmanRegionSubtract :: PixmanRegion32 -> PixmanRegion32 -> IO () 167 | pixmanRegionSubtract reg sub = withRegion32 reg $ \regPtr -> 168 | withRegion32 sub $ \subPtr -> 169 | c_32_subtract regPtr regPtr subPtr 170 | -------------------------------------------------------------------------------- /src/Graphics/Wayland/Global.hs: -------------------------------------------------------------------------------- 1 | module Graphics.Wayland.Global 2 | ( WlGlobal 3 | , FilterFun 4 | , setGlobalFilter 5 | ) 6 | where 7 | 8 | import Foreign.Ptr (Ptr, FunPtr, nullPtr, castPtrToFunPtr) 9 | import Graphics.Wayland.Server (DisplayServer (..), Client (..)) 10 | 11 | data WlGlobal 12 | 13 | type FilterFun = Ptr Client -> Ptr WlGlobal -> IO Bool 14 | type FilterFunPtr a = Ptr Client -> Ptr WlGlobal -> Ptr a -> IO Bool 15 | 16 | foreign import ccall "wl_display_set_global_filter" c_set_filter :: Ptr DisplayServer -> FunPtr (FilterFunPtr a) -> Ptr a -> IO () 17 | 18 | foreign import ccall "wrapper" mkCbFun :: (FilterFunPtr a) -> IO (FunPtr (FilterFunPtr a)) 19 | 20 | setGlobalFilter :: DisplayServer -> (Maybe FilterFun) -> IO () 21 | setGlobalFilter (DisplayServer ptr) Nothing = c_set_filter ptr (castPtrToFunPtr nullPtr) nullPtr 22 | setGlobalFilter (DisplayServer ptr) (Just fun) = do 23 | cb <- mkCbFun $ \c g _ -> fun c g 24 | c_set_filter ptr cb nullPtr 25 | 26 | 27 | -------------------------------------------------------------------------------- /src/Graphics/Wayland/List.hsc: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE EmptyDataDecls #-} 2 | module Graphics.Wayland.List 3 | ( WlList 4 | , getListFromHead 5 | , getListElems 6 | , isListEmpty 7 | ) 8 | where 9 | 10 | #include 11 | 12 | import Foreign.Storable (peekByteOff) 13 | import Foreign.Ptr (Ptr, plusPtr) 14 | 15 | data WlList 16 | 17 | getListElems' :: Ptr WlList -> Ptr WlList -> IO [Ptr WlList] 18 | getListElems' listHead current 19 | | listHead == current = pure [] 20 | | otherwise = do 21 | nxt <- #{peek struct wl_list, next} current 22 | (current :) <$> getListElems' listHead nxt 23 | 24 | 25 | getListElems :: Ptr WlList -> IO [Ptr WlList] 26 | getListElems listHead = do 27 | nxt <- #{peek struct wl_list, next} listHead 28 | getListElems' listHead nxt 29 | 30 | isListEmpty :: Ptr WlList -> IO Bool 31 | isListEmpty ptr = (==) ptr <$> #{peek struct wl_list, next} ptr 32 | 33 | getListFromHead :: Ptr WlList -> Word -> IO [Ptr a] 34 | getListFromHead listHead offset = 35 | map (flip plusPtr (negate $ fromIntegral offset)) <$> getListElems listHead 36 | -------------------------------------------------------------------------------- /src/Graphics/Wayland/Resource.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE EmptyDataDecls #-} 2 | module Graphics.Wayland.Resource 3 | ( WlResource 4 | , getUserData 5 | , resourceDestroy 6 | , resourceGetClient 7 | , resourceFromLink 8 | , addResourceDestroyListener 9 | ) 10 | where 11 | 12 | import Foreign.Ptr (Ptr) 13 | 14 | import Graphics.Wayland.List (WlList) 15 | import Graphics.Wayland.Server (Client (..)) 16 | import Graphics.Wayland.Signal 17 | 18 | data WlResource 19 | 20 | foreign import ccall unsafe "wl_resource_get_user_data" c_get_user_data :: Ptr WlResource -> Ptr a 21 | 22 | getUserData :: Ptr WlResource -> Ptr a 23 | getUserData = c_get_user_data 24 | 25 | foreign import ccall unsafe "wl_resource_destroy" c_resource_destroy :: Ptr WlResource -> IO () 26 | 27 | resourceDestroy :: Ptr WlResource -> IO () 28 | resourceDestroy = c_resource_destroy 29 | 30 | foreign import ccall unsafe "wl_resource_get_client" c_get_client :: Ptr WlResource -> IO (Ptr Client) 31 | 32 | resourceGetClient :: Ptr WlResource -> IO Client 33 | resourceGetClient = fmap Client . c_get_client 34 | 35 | foreign import ccall unsafe "wl_resource_from_link" c_from_link :: Ptr WlList -> Ptr WlResource 36 | 37 | resourceFromLink :: Ptr WlList -> Ptr WlResource 38 | resourceFromLink = c_from_link 39 | 40 | foreign import ccall unsafe "wl_resource_add_destroy_listener" c_add_listener :: Ptr WlResource -> Ptr (WlListener WlResource) -> IO () 41 | 42 | addResourceDestroyListener :: Ptr WlResource -> (Ptr WlResource -> IO ()) -> IO () 43 | addResourceDestroyListener rs act = 44 | addDestroyListener act (c_add_listener rs) 45 | -------------------------------------------------------------------------------- /src/Graphics/Wayland/Server/Client.hsc: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | module Graphics.Wayland.Server.Client 3 | where 4 | 5 | import Data.IORef (IORef, newIORef, writeIORef, readIORef) 6 | import Foreign.ForeignPtr (ForeignPtr, withForeignPtr) 7 | import Foreign.Ptr (Ptr) 8 | import Foreign.StablePtr (StablePtr, newStablePtr, freeStablePtr) 9 | 10 | import Graphics.Wayland.Server (Client (..)) 11 | import Graphics.Wayland.Signal 12 | ( WlListener(..) 13 | , makeListenerPtr 14 | ) 15 | 16 | foreign import ccall unsafe "wl_client_add_destroy_listener" c_add_listener :: Ptr Client -> Ptr (WlListener Client) -> IO () 17 | 18 | addDestroyListener :: Client -> (Client -> IO ()) -> IO () 19 | addDestroyListener (Client c) fun = do 20 | ref :: IORef (StablePtr (ForeignPtr (WlListener Client))) <- newIORef undefined 21 | lptr <- makeListenerPtr . WlListener $ \client -> do 22 | fun (Client client) 23 | freeStablePtr =<< readIORef ref 24 | writeIORef ref =<< newStablePtr lptr 25 | withForeignPtr lptr $ c_add_listener c 26 | -------------------------------------------------------------------------------- /src/Graphics/Wayland/Signal.hsc: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE EmptyDataDecls #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | {-# LANGUAGE ExistentialQuantification #-} 4 | module Graphics.Wayland.Signal 5 | ( WlSignal 6 | , WlListener (..) 7 | , ListenerToken 8 | 9 | , makeListenerPtr 10 | , addListener 11 | , removeListener 12 | , destroyListener 13 | , setSignalHandler 14 | , setDestroyHandler 15 | , addDestroyListener 16 | ) 17 | where 18 | 19 | -- We need the wl_lisener in scope 20 | #include 21 | 22 | import Control.Monad (when) 23 | import Control.Concurrent.MVar 24 | import Foreign.Storable (Storable(..)) 25 | import Foreign.Marshal.Alloc (mallocBytes, free) 26 | import Foreign.Ptr (Ptr, FunPtr, plusPtr, freeHaskellFunPtr, nullPtr, castFunPtrToPtr) 27 | import Foreign.ForeignPtr (ForeignPtr, withForeignPtr) 28 | import Foreign.Concurrent (newForeignPtr) 29 | 30 | data WlSignal a 31 | data WlList 32 | 33 | newtype WlListener a = WlListener (Ptr a -> IO ()) 34 | data ListenerToken = forall a. ListenerToken (ForeignPtr (WlListener a)) 35 | 36 | foreign import ccall unsafe "c_signal_add" c_signal_add :: Ptr (WlSignal a) -> Ptr (WlListener a) -> IO () 37 | foreign import ccall unsafe "wl_list_init" c_list_init :: Ptr WlList -> IO () 38 | foreign import ccall unsafe "wl_list_remove" c_list_remove :: Ptr WlList -> IO () 39 | 40 | destroyWlListener :: forall a. Ptr (WlListener a) -> IO () 41 | destroyWlListener ptr = do 42 | removeListener' ptr 43 | notify :: FunPtr (Ptr a -> IO ()) <- #{peek struct wl_listener, notify} ptr 44 | when (castFunPtrToPtr notify /= nullPtr) $ freeHaskellFunPtr notify 45 | #{poke struct wl_listener, notify} ptr nullPtr 46 | 47 | 48 | freeWlListener :: forall a. Ptr (WlListener a) -> IO () 49 | freeWlListener ptr = do 50 | destroyWlListener ptr 51 | free ptr 52 | 53 | foreign import ccall "wrapper" mkCbFun :: (Ptr (WlListener a) -> Ptr a -> IO ()) -> IO (FunPtr (Ptr (WlListener a) -> Ptr a -> IO ())) 54 | 55 | makeListenerPtr :: forall a. WlListener a -> IO (ForeignPtr (WlListener a)) 56 | makeListenerPtr (WlListener fun) = do 57 | mem :: Ptr (WlListener a) <- mallocBytes #{size struct wl_listener} 58 | let link = #{ptr struct wl_listener, link} mem 59 | c_list_init link 60 | funPtr <- mkCbFun (\_ -> fun) 61 | #{poke struct wl_listener, notify} mem funPtr 62 | newForeignPtr mem (freeWlListener mem) 63 | 64 | addListener :: WlListener a -> Ptr (WlSignal a) -> IO (ListenerToken) 65 | addListener listener signal = do 66 | ptr <- makeListenerPtr listener 67 | withForeignPtr ptr $ c_signal_add signal 68 | pure (ListenerToken ptr) 69 | 70 | destroyListener :: ListenerToken -> IO () 71 | destroyListener (ListenerToken ptr) = withForeignPtr ptr destroyWlListener 72 | 73 | removeListener :: ListenerToken -> IO () 74 | removeListener (ListenerToken ptr) = withForeignPtr ptr removeListener' 75 | 76 | removeListener' :: Ptr (WlListener a) -> IO () 77 | removeListener' ptr = 78 | let link = #{ptr struct wl_listener, link} ptr 79 | in do 80 | -- For some reason c_list_remove makes the elem point at null instead 81 | -- of itself, so we got to init it after, to *not* break things if we 82 | -- try to remove the element again 83 | c_list_remove link 84 | c_list_init link 85 | 86 | -- | Set a 'Way' action as signal handler. 87 | setSignalHandler :: Ptr (WlSignal a) -> (Ptr a -> IO ()) -> IO ListenerToken 88 | setSignalHandler signal act = addListener (WlListener act) signal 89 | 90 | -- | Set a signal handler that will remove itself after it's fired once. This 91 | -- can be used for destroy handlers that don't have to be stored anywhere. 92 | setDestroyHandler :: Ptr (WlSignal a) 93 | -> (Ptr a -> IO ()) 94 | -> IO () 95 | setDestroyHandler signal handler = do 96 | var <- newEmptyMVar 97 | listener <- flip addListener signal . WlListener $ \ptr -> do 98 | handler ptr 99 | (destroyListener =<< takeMVar var) 100 | putMVar var listener 101 | 102 | 103 | addDestroyListener :: (Ptr a -> IO ()) -> (Ptr (WlListener a) -> IO ()) -> IO () 104 | addDestroyListener fun adder = do 105 | var <- newEmptyMVar 106 | listener <- makeListenerPtr . WlListener $ \ptr -> do 107 | fun ptr 108 | (destroyListener =<< takeMVar var) 109 | withForeignPtr listener adder 110 | putMVar var (ListenerToken listener) 111 | -------------------------------------------------------------------------------- /src/Graphics/Wayland/WlRoots/Backend.hsc: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE EmptyDataDecls #-} 2 | module Graphics.Wayland.WlRoots.Backend 3 | ( Backend 4 | , backendAutocreate 5 | , backendStart 6 | , backendDestroy 7 | , getSession 8 | 9 | , BackendSignals (..) 10 | , backendGetSignals 11 | , backendGetRenderer 12 | ) 13 | where 14 | 15 | #define WLR_USE_UNSTABLE 16 | #include 17 | 18 | import Foreign.Ptr (Ptr, plusPtr, nullPtr) 19 | import Graphics.Wayland.Server (DisplayServer(..)) 20 | import Foreign.C.Error (throwErrnoIfNull, throwErrnoIf_) 21 | import Graphics.Wayland.Signal (WlSignal) 22 | import Graphics.Wayland.WlRoots.Backend.Session (WlrSession) 23 | import Graphics.Wayland.WlRoots.Input (InputDevice) 24 | import Graphics.Wayland.WlRoots.Output (WlrOutput) 25 | import Graphics.Wayland.WlRoots.Render (Renderer) 26 | 27 | data Backend 28 | 29 | foreign import ccall unsafe "wlr_backend_autocreate" c_backend_autocreate :: Ptr DisplayServer -> Ptr a -> IO (Ptr Backend) 30 | 31 | backendAutocreate :: DisplayServer -> IO (Ptr Backend) 32 | backendAutocreate (DisplayServer ptr) = throwErrnoIfNull "backendAutocreate" $ c_backend_autocreate ptr nullPtr 33 | 34 | 35 | foreign import ccall safe "wlr_backend_start" c_backend_start :: Ptr Backend -> IO Bool 36 | 37 | backendStart :: Ptr Backend -> IO () 38 | backendStart = throwErrnoIf_ not "backendStart" . c_backend_start 39 | 40 | 41 | foreign import ccall safe "wlr_backend_destroy" c_backend_destroy :: Ptr Backend -> IO () 42 | 43 | backendDestroy :: Ptr Backend -> IO () 44 | backendDestroy = c_backend_destroy 45 | 46 | data BackendSignals = BackendSignals 47 | { backendEvtInput :: Ptr (WlSignal InputDevice) 48 | , backendEvtOutput :: Ptr (WlSignal WlrOutput) 49 | , backendEvtDestroy :: Ptr (WlSignal Backend) 50 | } 51 | 52 | backendGetSignals :: Ptr Backend -> BackendSignals 53 | backendGetSignals ptr = 54 | let input_add = #{ptr struct wlr_backend, events.new_input} ptr 55 | output_add = #{ptr struct wlr_backend, events.new_output} ptr 56 | destroy = #{ptr struct wlr_backend, events.destroy} ptr 57 | in BackendSignals 58 | { backendEvtInput = input_add 59 | , backendEvtOutput = output_add 60 | , backendEvtDestroy = destroy 61 | } 62 | 63 | foreign import ccall "wlr_backend_get_renderer" c_get_renderer :: Ptr Backend -> IO (Ptr Renderer) 64 | 65 | backendGetRenderer :: Ptr Backend -> IO (Ptr Renderer) 66 | backendGetRenderer = c_get_renderer 67 | 68 | foreign import ccall unsafe "wlr_backend_get_session" c_get_session :: Ptr Backend -> IO (Ptr WlrSession) 69 | 70 | getSession :: Ptr Backend -> IO (Maybe (Ptr WlrSession)) 71 | getSession b = do 72 | s <- c_get_session b 73 | pure $ if s == nullPtr 74 | then Nothing 75 | else Just s 76 | -------------------------------------------------------------------------------- /src/Graphics/Wayland/WlRoots/Backend/Headless.hsc: -------------------------------------------------------------------------------- 1 | module Graphics.Wayland.WlRoots.Backend.Headless 2 | ( backendIsHeadless 3 | , inputDeviceIsHeadless 4 | , addHeadlessInput 5 | , createHeadlessBackend 6 | ) 7 | where 8 | 9 | #define WLR_USE_UNSTABLE 10 | #include 11 | 12 | import Foreign.C.Error (throwErrnoIfNull) 13 | import Foreign.C.Types (CInt (..)) 14 | import Data.Word (Word8) 15 | import Foreign.Ptr (Ptr, nullPtr) 16 | 17 | import Graphics.Wayland.Server (DisplayServer (..)) 18 | 19 | import Graphics.Wayland.WlRoots.Backend 20 | import Graphics.Wayland.WlRoots.Input 21 | 22 | foreign import ccall unsafe "wlr_backend_is_headless" c_is_headless :: Ptr Backend -> IO Word8 23 | 24 | backendIsHeadless :: Ptr Backend -> IO Bool 25 | backendIsHeadless = fmap (/= 0) . c_is_headless 26 | 27 | foreign import ccall unsafe "wlr_input_device_is_headless" c_input_is_headless :: Ptr InputDevice -> IO Word8 28 | 29 | inputDeviceIsHeadless :: Ptr InputDevice -> IO Bool 30 | inputDeviceIsHeadless = fmap (/= 0) . c_input_is_headless 31 | 32 | foreign import ccall "wlr_headless_add_input_device" c_add_input :: Ptr Backend -> CInt -> IO (Ptr InputDevice) 33 | 34 | addHeadlessInput :: Ptr Backend -> (Ptr a -> DeviceType) -> IO (Maybe (Ptr InputDevice)) 35 | addHeadlessInput backend devType = do 36 | isHeadless <- backendIsHeadless backend 37 | if not isHeadless 38 | then pure Nothing 39 | else Just <$> c_add_input backend (deviceTypeToInt $ devType nullPtr) 40 | 41 | foreign import ccall unsafe "wlr_headless_backend_create" c_headless_create :: Ptr DisplayServer -> IO (Ptr Backend) 42 | 43 | createHeadlessBackend :: DisplayServer -> IO (Ptr Backend) 44 | createHeadlessBackend (DisplayServer ptr) = 45 | throwErrnoIfNull "createHeadlessBackend" $ c_headless_create ptr 46 | -------------------------------------------------------------------------------- /src/Graphics/Wayland/WlRoots/Backend/Libinput.hsc: -------------------------------------------------------------------------------- 1 | module Graphics.Wayland.WlRoots.Backend.Libinput 2 | ( backendIsLibinput 3 | , inputDeviceIsLibinput 4 | , getDeviceHandle 5 | ) 6 | where 7 | 8 | import Data.Word (Word8) 9 | import Foreign.Ptr (Ptr) 10 | 11 | import Graphics.Wayland.WlRoots.Backend 12 | import Graphics.Wayland.WlRoots.Input 13 | 14 | import qualified System.InputDevice as LI 15 | 16 | foreign import ccall unsafe "wlr_backend_is_libinput" c_is_libinput :: Ptr Backend -> IO Word8 17 | 18 | backendIsLibinput :: Ptr Backend -> IO Bool 19 | backendIsLibinput = fmap (/= 0) . c_is_libinput 20 | 21 | foreign import ccall unsafe "wlr_input_device_is_libinput" c_input_is_libinput :: Ptr InputDevice -> IO Word8 22 | 23 | inputDeviceIsLibinput :: Ptr InputDevice -> IO Bool 24 | inputDeviceIsLibinput = fmap (/= 0) . c_input_is_libinput 25 | 26 | foreign import ccall unsafe "wlr_libinput_get_device_handle" c_get_handle :: Ptr InputDevice -> IO LI.InputDevice 27 | 28 | getDeviceHandle :: Ptr InputDevice -> IO (Maybe LI.InputDevice) 29 | getDeviceHandle ptr = do 30 | isLibinput <- inputDeviceIsLibinput ptr 31 | if isLibinput 32 | then Just <$> c_get_handle ptr 33 | else pure Nothing 34 | -------------------------------------------------------------------------------- /src/Graphics/Wayland/WlRoots/Backend/Multi.hs: -------------------------------------------------------------------------------- 1 | module Graphics.Wayland.WlRoots.Backend.Multi 2 | ( isMulti 3 | 4 | , addBackend 5 | ) 6 | where 7 | 8 | import Data.Word (Word8) 9 | import Foreign.Ptr (Ptr) 10 | 11 | import Graphics.Wayland.WlRoots.Backend (Backend) 12 | 13 | 14 | foreign import ccall unsafe "wlr_backend_is_multi" c_is_multi :: Ptr Backend -> IO Word8 15 | 16 | isMulti :: Ptr Backend -> IO Bool 17 | isMulti = fmap (/= 0) . c_is_multi 18 | 19 | foreign import ccall "wlr_multi_backend_add" c_multi_add :: Ptr Backend -> Ptr Backend -> IO () 20 | 21 | addBackend :: Ptr Backend -> Ptr Backend -> IO () 22 | addBackend = c_multi_add 23 | -------------------------------------------------------------------------------- /src/Graphics/Wayland/WlRoots/Backend/Session.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE EmptyDataDecls #-} 2 | module Graphics.Wayland.WlRoots.Backend.Session 3 | ( WlrSession 4 | , changeVT 5 | ) 6 | where 7 | 8 | import Foreign.Ptr (Ptr) 9 | import Foreign.C.Types (CUInt(..)) 10 | 11 | import Foreign.C.Error (throwErrnoIf_) 12 | 13 | data WlrSession 14 | 15 | 16 | foreign import ccall unsafe "wlr_session_change_vt" c_change_vt :: Ptr WlrSession -> CUInt -> IO Bool 17 | 18 | changeVT :: Ptr WlrSession -> Word -> IO () 19 | changeVT ptr vt = throwErrnoIf_ not "changeVT" $ c_change_vt ptr (fromIntegral vt) 20 | -------------------------------------------------------------------------------- /src/Graphics/Wayland/WlRoots/Box.hsc: -------------------------------------------------------------------------------- 1 | module Graphics.Wayland.WlRoots.Box 2 | ( WlrBox (..) 3 | , Point (..) 4 | 5 | , boxContainsPoint 6 | , centerBox 7 | , toOrigin 8 | , shrink 9 | , enlarge 10 | , boxTransform 11 | , scaleBox 12 | , translateBox 13 | ) 14 | where 15 | 16 | #define WLR_USE_UNSTABLE 17 | #include 18 | 19 | import System.IO.Unsafe (unsafePerformIO) 20 | import Foreign.C.Types (CInt(..)) 21 | import Foreign.Ptr (Ptr) 22 | import Foreign.Storable (Storable(..)) 23 | import Foreign.Marshal.Alloc (alloca) 24 | import Foreign.Marshal.Utils (with) 25 | 26 | import Graphics.Wayland.Server (OutputTransform(..)) 27 | 28 | data WlrBox = WlrBox 29 | { boxX :: Int 30 | , boxY :: Int 31 | , boxWidth :: Int 32 | , boxHeight :: Int 33 | } deriving (Eq, Show) 34 | 35 | data Point = Point { pointX :: Int, pointY :: Int } 36 | deriving (Eq, Show) 37 | 38 | boxContainsPoint :: Point -> WlrBox -> Bool 39 | boxContainsPoint (Point px py) (WlrBox bx by bw bh) = 40 | bx <= px && px - bx <= bw && by <= py && py - by <= bh 41 | 42 | readCInt :: IO CInt -> IO Int 43 | readCInt = fmap fromIntegral 44 | 45 | toCInt :: Integral a => a -> CInt 46 | toCInt = fromIntegral 47 | 48 | instance Storable WlrBox where 49 | sizeOf _ = #{size struct wlr_box} 50 | alignment _ = #{alignment struct wlr_box} 51 | peek ptr = WlrBox 52 | <$> readCInt (#{peek struct wlr_box, x} ptr) 53 | <*> readCInt (#{peek struct wlr_box, y} ptr) 54 | <*> readCInt (#{peek struct wlr_box, width} ptr) 55 | <*> readCInt (#{peek struct wlr_box, height} ptr) 56 | poke ptr box = do 57 | #{poke struct wlr_box, x} ptr . toCInt $ boxX box 58 | #{poke struct wlr_box, y} ptr . toCInt $ boxY box 59 | #{poke struct wlr_box, width} ptr . toCInt $ boxWidth box 60 | #{poke struct wlr_box, height} ptr . toCInt $ boxHeight box 61 | 62 | -- | Center the first argument in the second 63 | -- This doesn't produce an error, but weird results when the box to be centered 64 | -- is bigger than the box to center in! 65 | centerBox :: WlrBox -> WlrBox -> WlrBox 66 | centerBox (WlrBox _ _ innerW innerH) (WlrBox x y outerW outerH) = 67 | let offX = (outerW - innerW) `div` 2 68 | offY = (outerH - innerH) `div` 2 69 | in WlrBox (x + offX) (y + offY) innerW innerH 70 | 71 | toOrigin :: WlrBox -> WlrBox 72 | toOrigin (WlrBox {boxWidth = width, boxHeight = height}) = WlrBox 0 0 width height 73 | 74 | shrink :: WlrBox -> WlrBox -> WlrBox 75 | shrink (WlrBox _ _ lw lh) (WlrBox _ _ rw rh) = WlrBox 0 0 (min lw rw) (min lh rh) 76 | 77 | enlarge :: WlrBox -> WlrBox -> WlrBox 78 | enlarge (WlrBox _ _ lw lh) (WlrBox _ _ rw rh) = WlrBox 0 0 (max lw rw) (max lh rh) 79 | 80 | scaleBox :: WlrBox -> Float -> WlrBox 81 | scaleBox (WlrBox x y w h) factor = WlrBox 82 | (ceiling $ fromIntegral x * factor) 83 | (ceiling $ fromIntegral y * factor) 84 | (ceiling $ fromIntegral w * factor) 85 | (ceiling $ fromIntegral h * factor) 86 | 87 | translateBox :: Int -> Int -> WlrBox -> WlrBox 88 | translateBox x y (WlrBox bx by bh bw) = WlrBox (x + bx) (y + by) bh bw 89 | 90 | -- void wlr_box_transform(const struct wlr_box *box, 91 | -- enum wl_output_transform transform, int width, int height, 92 | -- struct wlr_box *dest); 93 | foreign import ccall unsafe "wlr_box_transform" c_transform :: Ptr WlrBox -> Ptr WlrBox -> CInt -> CInt -> CInt -> IO () 94 | 95 | boxTransform' :: WlrBox -> OutputTransform -> Int -> Int -> IO WlrBox 96 | boxTransform' box (OutputTransform val) x y = alloca $ \ret -> do 97 | with box $ \boxPtr -> 98 | c_transform ret boxPtr (fromIntegral val) (fromIntegral x) (fromIntegral y) 99 | peek ret 100 | 101 | boxTransform :: WlrBox -> OutputTransform -> Int -> Int -> WlrBox 102 | boxTransform box trans width height = 103 | unsafePerformIO $ boxTransform' box trans width height 104 | {-# NOINLINE boxTransform #-} 105 | -------------------------------------------------------------------------------- /src/Graphics/Wayland/WlRoots/Buffer.hsc: -------------------------------------------------------------------------------- 1 | module Graphics.Wayland.WlRoots.Buffer 2 | ( WlrBuffer (..) 3 | , getBufferResource 4 | , getBuffer 5 | , putBuffer 6 | , getTexture 7 | ) 8 | where 9 | 10 | #define WLR_USE_UNSTABLE 11 | #include 12 | 13 | import Foreign.Storable 14 | import Foreign.Ptr (Ptr, nullPtr) 15 | 16 | import Graphics.Wayland.Resource (WlResource) 17 | import Graphics.Wayland.WlRoots.Render (Texture) 18 | 19 | newtype WlrBuffer = WlrBuffer (Ptr WlrBuffer) 20 | 21 | getBufferResource :: WlrBuffer -> IO (Maybe (Ptr WlResource)) 22 | getBufferResource (WlrBuffer ptr) = do 23 | ret <- #{peek struct wlr_buffer, resource} ptr 24 | if ret == nullPtr 25 | then pure Nothing 26 | else pure $ Just ret 27 | 28 | foreign import ccall unsafe "wlr_buffer_ref" c_ref :: Ptr WlrBuffer -> IO () 29 | 30 | getBuffer :: WlrBuffer -> IO WlrBuffer 31 | getBuffer b@(WlrBuffer ptr) = c_ref ptr >> pure b 32 | 33 | foreign import ccall unsafe "wlr_buffer_unref" c_unref :: Ptr WlrBuffer -> IO () 34 | 35 | putBuffer :: WlrBuffer -> IO () 36 | putBuffer (WlrBuffer ptr) = c_unref ptr 37 | 38 | getTexture :: WlrBuffer -> IO (Maybe (Ptr Texture)) 39 | getTexture (WlrBuffer ptr) = do 40 | ret <- #{peek struct wlr_buffer, texture} ptr 41 | if ret == nullPtr 42 | then pure Nothing 43 | else pure $ Just ret 44 | -------------------------------------------------------------------------------- /src/Graphics/Wayland/WlRoots/Compositor.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE EmptyDataDecls #-} 2 | module Graphics.Wayland.WlRoots.Compositor 3 | ( WlrCompositor 4 | , compositorCreate 5 | , compositorDestroy 6 | ) 7 | where 8 | 9 | import Foreign.Ptr (Ptr) 10 | import Foreign.C.Error (throwErrnoIfNull) 11 | import Graphics.Wayland.Server (DisplayServer(..)) 12 | import Graphics.Wayland.WlRoots.Render (Renderer) 13 | 14 | data WlrCompositor 15 | 16 | foreign import ccall "wlr_compositor_create" c_compositor_create :: Ptr DisplayServer -> Ptr Renderer -> IO (Ptr WlrCompositor) 17 | 18 | compositorCreate :: DisplayServer -> Ptr Renderer -> IO (Ptr WlrCompositor) 19 | compositorCreate (DisplayServer ptr) backend = 20 | throwErrnoIfNull "compositorCreate" $ c_compositor_create ptr backend 21 | 22 | foreign import ccall "wlr_compositor_destroy" c_compositor_destroy :: Ptr WlrCompositor -> IO () 23 | 24 | compositorDestroy :: Ptr WlrCompositor -> IO () 25 | compositorDestroy = c_compositor_destroy 26 | -------------------------------------------------------------------------------- /src/Graphics/Wayland/WlRoots/Cursor.hsc: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TupleSections #-} 2 | module Graphics.Wayland.WlRoots.Cursor 3 | ( WlrCursor 4 | , createCursor 5 | , destroyCursor 6 | 7 | , getCursorX 8 | , getCursorY 9 | 10 | , setXCursor 11 | , warpCursor 12 | , warpCursorAbs 13 | , moveCursor 14 | , attachInputDevice 15 | , detachInputDevice 16 | , attachOutputLayout 17 | 18 | , mapToOutput 19 | , mapInputToOutput 20 | 21 | , mapToRegion 22 | 23 | , CursorEvents (..) 24 | , cursorGetEvents 25 | , setCursorImage 26 | , setCursorSurface 27 | , absCoordsToGlobal 28 | ) 29 | where 30 | 31 | #define WLR_USE_UNSTABLE 32 | #include 33 | 34 | import Data.Word (Word32, Word8) 35 | import Data.Int (Int32) 36 | import Data.Maybe (fromMaybe) 37 | import Foreign.C.Error (throwErrnoIfNull, throwErrnoIf_) 38 | import Foreign.Ptr (Ptr, nullPtr, plusPtr) 39 | import Foreign.Storable (Storable(..)) 40 | import Foreign.Marshal.Alloc (alloca) 41 | import Graphics.Wayland.Signal (WlSignal) 42 | import Graphics.Wayland.WlRoots.Box (WlrBox) 43 | import Graphics.Wayland.WlRoots.Input (InputDevice) 44 | import Graphics.Wayland.WlRoots.Input.Pointer 45 | (WlrEventPointerButton, WlrEventPointerMotion, WlrEventPointerAbsMotion, WlrEventPointerAxis) 46 | import Graphics.Wayland.WlRoots.Input.Tablet 47 | (ToolAxisEvent, ToolProximityEvent, ToolTipEvent, ToolButtonEvent) 48 | import Graphics.Wayland.WlRoots.Input.Touch 49 | import Graphics.Wayland.WlRoots.Output (WlrOutput) 50 | import Graphics.Wayland.WlRoots.OutputLayout (WlrOutputLayout) 51 | import Graphics.Wayland.WlRoots.XCursor (WlrXCursor) 52 | import Graphics.Wayland.WlRoots.Surface (WlrSurface) 53 | 54 | data CursorEvents = CursorEvents 55 | { cursorButton :: !(Ptr (WlSignal WlrEventPointerButton)) 56 | , cursorMotion :: !(Ptr (WlSignal WlrEventPointerMotion)) 57 | , cursorMotionAbs :: !(Ptr (WlSignal WlrEventPointerAbsMotion)) 58 | , cursorAxis :: !(Ptr (WlSignal WlrEventPointerAxis)) 59 | 60 | , cursorTouchDown :: !(Ptr (WlSignal WlrTouchDown)) 61 | , cursorTouchUp :: !(Ptr (WlSignal WlrTouchUp)) 62 | , cursorTouchMotion :: !(Ptr (WlSignal WlrTouchMotion)) 63 | , cursorTouchCancel :: !(Ptr (WlSignal WlrTouchCancel)) 64 | 65 | , cursorToolAxis :: !(Ptr (WlSignal ToolAxisEvent)) 66 | , cursorToolProximity :: !(Ptr (WlSignal ToolProximityEvent)) 67 | , cursorToolTip :: !(Ptr (WlSignal ToolTipEvent)) 68 | , cursorToolButton :: !(Ptr (WlSignal ToolButtonEvent)) 69 | } 70 | 71 | cursorGetEvents :: Ptr WlrCursor -> CursorEvents 72 | cursorGetEvents ptr = CursorEvents 73 | { cursorButton = #{ptr struct wlr_cursor, events.button} ptr 74 | , cursorMotion = #{ptr struct wlr_cursor, events.motion} ptr 75 | , cursorMotionAbs = #{ptr struct wlr_cursor, events.motion_absolute} ptr 76 | , cursorAxis = #{ptr struct wlr_cursor, events.axis} ptr 77 | 78 | , cursorTouchDown = #{ptr struct wlr_cursor, events.touch_down} ptr 79 | , cursorTouchUp = #{ptr struct wlr_cursor, events.touch_up} ptr 80 | , cursorTouchCancel = #{ptr struct wlr_cursor, events.touch_cancel} ptr 81 | , cursorTouchMotion = #{ptr struct wlr_cursor, events.touch_motion} ptr 82 | 83 | , cursorToolAxis = #{ptr struct wlr_cursor, events.tablet_tool_axis} ptr 84 | , cursorToolProximity = #{ptr struct wlr_cursor, events.tablet_tool_proximity} ptr 85 | , cursorToolTip = #{ptr struct wlr_cursor, events.tablet_tool_tip} ptr 86 | , cursorToolButton = #{ptr struct wlr_cursor, events.tablet_tool_button} ptr 87 | } 88 | 89 | data WlrCursor 90 | 91 | foreign import ccall "wlr_cursor_create" c_cursor_create :: IO (Ptr WlrCursor) 92 | 93 | createCursor :: IO (Ptr WlrCursor) 94 | createCursor = throwErrnoIfNull "createCursor" c_cursor_create 95 | 96 | getCursorX :: Ptr WlrCursor -> IO Double 97 | getCursorX = #{peek struct wlr_cursor, x} 98 | 99 | getCursorY :: Ptr WlrCursor -> IO Double 100 | getCursorY = #{peek struct wlr_cursor, y} 101 | 102 | 103 | foreign import ccall "wlr_cursor_destroy" c_cursor_destroy :: Ptr WlrCursor -> IO () 104 | 105 | destroyCursor :: Ptr WlrCursor -> IO () 106 | destroyCursor = c_cursor_destroy 107 | 108 | 109 | setXCursor :: Ptr WlrCursor -> Ptr WlrXCursor -> IO () 110 | setXCursor = \_ _ -> pure () 111 | --c_set_xcursor 112 | 113 | 114 | foreign import ccall "wlr_cursor_warp" c_cursor_warp :: Ptr WlrCursor -> Ptr InputDevice -> Double -> Double -> IO Bool 115 | 116 | warpCursor :: Ptr WlrCursor -> Maybe (Ptr InputDevice) -> Double -> Double -> IO Bool 117 | warpCursor cursor Nothing x y = warpCursor cursor (Just nullPtr) x y 118 | warpCursor cursor (Just dev) x y = c_cursor_warp cursor dev x y 119 | 120 | 121 | foreign import ccall "wlr_cursor_warp_absolute" c_cursor_warp_abs :: Ptr WlrCursor -> Ptr InputDevice -> Double -> Double -> IO () 122 | 123 | warpCursorAbs :: Ptr WlrCursor -> Maybe (Ptr InputDevice) -> Maybe Double -> Maybe Double -> IO () 124 | warpCursorAbs cursor Nothing x y = warpCursorAbs cursor (Just nullPtr) x y 125 | warpCursorAbs cursor (Just dev) x y = 126 | c_cursor_warp_abs cursor dev (fromMaybe (-1) x) (fromMaybe (-1) y) 127 | 128 | 129 | foreign import ccall "wlr_cursor_move" c_cursor_move :: Ptr WlrCursor -> Ptr InputDevice -> Double -> Double -> IO () 130 | 131 | moveCursor :: Ptr WlrCursor -> Maybe (Ptr InputDevice) -> Double -> Double -> IO () 132 | moveCursor cursor Nothing x y = moveCursor cursor (Just nullPtr) x y 133 | moveCursor cursor (Just dev) x y = c_cursor_move cursor dev x y 134 | 135 | 136 | foreign import ccall "wlr_cursor_attach_input_device" c_attach_input_device :: Ptr WlrCursor -> Ptr InputDevice -> IO () 137 | 138 | attachInputDevice :: Ptr WlrCursor -> Ptr InputDevice -> IO () 139 | attachInputDevice = c_attach_input_device 140 | 141 | 142 | foreign import ccall "wlr_cursor_detach_input_device" c_detach_input_device :: Ptr WlrCursor -> Ptr InputDevice -> IO () 143 | 144 | detachInputDevice :: Ptr WlrCursor -> Ptr InputDevice -> IO () 145 | detachInputDevice = c_detach_input_device 146 | 147 | 148 | foreign import ccall "wlr_cursor_attach_output_layout" c_attach_layout :: Ptr WlrCursor -> Ptr WlrOutputLayout -> IO () 149 | 150 | attachOutputLayout :: Ptr WlrCursor -> Ptr WlrOutputLayout -> IO () 151 | attachOutputLayout = c_attach_layout 152 | 153 | 154 | foreign import ccall "wlr_cursor_map_to_output" c_map_to_output :: Ptr WlrCursor -> Ptr WlrOutput -> IO () 155 | 156 | mapToOutput :: Ptr WlrCursor -> Ptr WlrOutput -> IO () 157 | mapToOutput = c_map_to_output 158 | 159 | 160 | foreign import ccall "wlr_cursor_map_input_to_output" c_map_intput_to_output :: Ptr WlrCursor -> Ptr InputDevice -> Ptr WlrOutput -> IO () 161 | 162 | mapInputToOutput :: Ptr WlrCursor -> Ptr InputDevice -> Ptr WlrOutput -> IO () 163 | mapInputToOutput = c_map_intput_to_output 164 | 165 | 166 | foreign import ccall "wlr_cursor_map_to_region" c_map_to_region :: Ptr WlrCursor -> Ptr WlrBox -> IO () 167 | 168 | mapToRegion :: Ptr WlrCursor -> Maybe (Ptr WlrBox) -> IO () 169 | mapToRegion cursor Nothing = mapToRegion cursor (Just nullPtr) 170 | mapToRegion cursor (Just box) = c_map_to_region cursor box 171 | 172 | --void wlr_cursor_set_image(struct wlr_cursor *cur, const uint8_t *pixels, 173 | -- int32_t stride, uint32_t width, uint32_t height, int32_t hotspot_x, 174 | -- int32_t hotspot_y); 175 | 176 | foreign import ccall "wlr_cursor_set_image" c_set_cursor_image :: Ptr WlrCursor -> Ptr () -> Word32 -> Word32 -> Word32 -> Word32 -> Word32 -> IO Bool 177 | 178 | 179 | setCursorImage :: Ptr WlrCursor -> Ptr () -> Word32 -> Word32 -> Word32 -> Word32 -> Word32 -> IO () 180 | setCursorImage cursor buffer stride width height hotspot_x hotspot_y = 181 | throwErrnoIf_ not "setCursorImage" $ c_set_cursor_image cursor buffer stride width height hotspot_x hotspot_y 182 | 183 | foreign import ccall "wlr_cursor_set_surface" c_set_surface :: Ptr WlrCursor -> Ptr WlrSurface -> Int32 -> Int32 -> IO () 184 | 185 | setCursorSurface :: Integral a => Ptr WlrCursor -> Ptr WlrSurface -> a -> a -> IO () 186 | setCursorSurface cursor surface hotspotX hotspotY = c_set_surface cursor surface (fromIntegral hotspotX) (fromIntegral hotspotY) 187 | 188 | 189 | -- bool wlr_cursor_absolute_to_layout_coords(struct wlr_cursor *cur,struct wlr_input_device *device, double x_mm, double y_mm,double width_mm, double height_mm, double *lx, double *ly) { 190 | 191 | foreign import ccall unsafe "wlr_cursor_absolute_to_layout_coords" c_absolute_to_layout_coords :: Ptr WlrCursor -> Ptr InputDevice -> Double -> Double -> Ptr Double -> Ptr Double -> IO Word8 192 | 193 | absCoordsToGlobal :: Ptr WlrCursor -> Ptr InputDevice -> Double -> Double -> IO (Double, Double) 194 | absCoordsToGlobal cursor dev x y = alloca $ \xptr -> alloca $ \yptr -> do 195 | _ <- c_absolute_to_layout_coords cursor dev x y xptr yptr 196 | (,) <$> peek xptr <*> peek yptr 197 | -------------------------------------------------------------------------------- /src/Graphics/Wayland/WlRoots/DataControl.hsc: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Graphics.Wayland.WlRoots.DataControl 3 | ( DataControlManager (..) 4 | , dataControlManagerCreate 5 | , dataControlManagerDestroy 6 | ) 7 | where 8 | 9 | #define WLR_USE_UNSTABLE 10 | #include 11 | 12 | import Foreign.Ptr (Ptr) 13 | import Graphics.Wayland.Server (DisplayServer(..)) 14 | 15 | import Foreign.C.Error (throwErrnoIfNull) 16 | 17 | newtype DataControlManager = DataControlManager {unDCM :: Ptr DataControlManager} 18 | 19 | foreign import ccall unsafe "wlr_data_control_manager_v1_create" c_create :: Ptr DisplayServer -> IO (Ptr DataControlManager) 20 | dataControlManagerCreate :: DisplayServer -> IO DataControlManager 21 | dataControlManagerCreate (DisplayServer dsp) = fmap DataControlManager . throwErrnoIfNull "dataControlManagerCreate" $ c_create dsp 22 | 23 | foreign import ccall unsafe "wlr_data_control_manager_v1_destroy" c_destroy :: Ptr DataControlManager -> IO () 24 | dataControlManagerDestroy :: DataControlManager -> IO () 25 | dataControlManagerDestroy = c_destroy . unDCM 26 | -------------------------------------------------------------------------------- /src/Graphics/Wayland/WlRoots/DeviceManager.hsc: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE EmptyDataDecls #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | module Graphics.Wayland.WlRoots.DeviceManager 4 | ( WlrDeviceManager 5 | , managerCreate 6 | 7 | , WlrDataSource (..) 8 | , sendDataSend 9 | , getSelectionText 10 | ) 11 | where 12 | 13 | #define WLR_USE_UNSTABLE 14 | #include 15 | 16 | import Data.ByteString (useAsCString) 17 | import Data.Text (Text) 18 | import Foreign.C.Error (throwErrnoIfNull) 19 | import Foreign.C.Types (CChar, CInt (..)) 20 | import Foreign.Ptr (Ptr, FunPtr) 21 | import Foreign.Storable (Storable (..)) 22 | import System.Posix.IO (createPipe) 23 | import System.Posix.Types (Fd (..)) 24 | 25 | import Graphics.Wayland.Server (DisplayServer(..)) 26 | 27 | -- import qualified Data.Text as T 28 | import qualified Data.Text.Encoding as E 29 | 30 | data WlrDeviceManager 31 | 32 | foreign import ccall unsafe "wlr_data_device_manager_create" c_manager_create :: Ptr DisplayServer -> IO (Ptr WlrDeviceManager) 33 | 34 | managerCreate :: DisplayServer -> IO (Ptr WlrDeviceManager) 35 | managerCreate (DisplayServer ptr) = 36 | throwErrnoIfNull "managerCreate" $ c_manager_create ptr 37 | 38 | 39 | newtype WlrDataSource = WlrDataSource { unDS :: Ptr WlrDataSource } deriving (Show, Eq) 40 | 41 | foreign import ccall "dynamic" 42 | mkSendFun :: FunPtr (Ptr WlrDataSource -> Ptr CChar -> Fd -> IO ()) 43 | -> Ptr WlrDataSource -> Ptr CChar -> Fd -> IO () 44 | 45 | wrapSendFun :: WlrDataSource -> IO (Ptr WlrDataSource -> Ptr CChar -> Fd -> IO ()) 46 | wrapSendFun (WlrDataSource ptr) = do 47 | impl <- #{peek struct wlr_data_source, impl} ptr 48 | mkSendFun <$> #{peek struct wlr_data_source_impl, send} impl 49 | 50 | getSendFun :: WlrDataSource -> IO (Text -> Fd -> IO ()) 51 | getSendFun source = do 52 | fun <- wrapSendFun source 53 | pure $ realFun (fun $ unDS source) 54 | where realFun :: (Ptr CChar -> Fd -> IO ()) -> Text -> Fd -> IO () 55 | realFun fun txt fd = useAsCString (E.encodeUtf8 txt) $ \cstr -> 56 | fun cstr fd 57 | 58 | sendDataSend :: WlrDataSource -> Text -> Fd -> IO () 59 | sendDataSend device txt fd = do 60 | fun <- getSendFun device 61 | fun txt fd 62 | 63 | getSelection :: WlrDataSource -> Text -> IO Fd 64 | getSelection source mime = do 65 | (rFd, wFd) <- createPipe 66 | sendDataSend source mime wFd 67 | 68 | pure rFd 69 | 70 | -- WARNING: This may be moved out of here 71 | getSelectionText :: WlrDataSource -> IO Fd 72 | getSelectionText source = getSelection source "text/plain" 73 | -------------------------------------------------------------------------------- /src/Graphics/Wayland/WlRoots/Egl.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE EmptyDataDecls #-} 2 | module Graphics.Wayland.WlRoots.Egl 3 | ( EGL 4 | , eglInit 5 | , eglBindDisplay 6 | ) 7 | where 8 | 9 | import Data.Composition ((.:)) 10 | import Graphics.Wayland.Server (Display) 11 | import Graphics.Egl (Platform, getPlatform) 12 | import Foreign.Ptr (Ptr) 13 | import Foreign.C.Types (CInt(..)) 14 | import Foreign.C.Error (throwErrnoIf_) 15 | 16 | data EGL 17 | 18 | 19 | foreign import ccall unsafe "wlr_egl_init" c_egl_init :: Ptr EGL -> CInt -> Ptr a -> IO Bool 20 | 21 | eglInit :: Ptr EGL -> Platform -> Ptr a -> IO () 22 | eglInit e p d = let num = getPlatform p in 23 | throwErrnoIf_ not "eglInit" (c_egl_init e num d) 24 | 25 | 26 | foreign import ccall unsafe "wlr_egl_bind_display" c_egl_bind_display :: Ptr EGL -> Ptr Display -> IO Bool 27 | 28 | eglBindDisplay :: Ptr EGL -> Ptr Display -> IO () 29 | eglBindDisplay = 30 | throwErrnoIf_ not "eglBindDisplay" .: c_egl_bind_display 31 | 32 | -- TODO: wlr_egl_query_buffer 33 | 34 | 35 | 36 | -------------------------------------------------------------------------------- /src/Graphics/Wayland/WlRoots/ExportDMABuf.hsc: -------------------------------------------------------------------------------- 1 | module Graphics.Wayland.WlRoots.ExportDMABuf 2 | ( ExportDMABufManager (..) 3 | 4 | , createDMAExporter 5 | , destroyDMAExporter 6 | ) 7 | where 8 | 9 | #define WLR_USE_UNSTABLE 10 | #include 11 | 12 | import Foreign.Ptr (Ptr) 13 | import Foreign.C.Error (throwErrnoIfNull) 14 | 15 | import Graphics.Wayland.Server (DisplayServer (..)) 16 | 17 | newtype ExportDMABufManager = ExportDMABufManager (Ptr ExportDMABufManager) 18 | 19 | foreign import ccall unsafe "wlr_export_dmabuf_manager_v1_create" c_create :: Ptr DisplayServer -> IO (Ptr ExportDMABufManager) 20 | 21 | createDMAExporter :: DisplayServer -> IO ExportDMABufManager 22 | createDMAExporter (DisplayServer ptr) = ExportDMABufManager <$> 23 | throwErrnoIfNull "createDMAExporter" (c_create ptr) 24 | 25 | foreign import ccall unsafe "wlr_export_dmabuf_manager_v1_destroy" c_destroy :: Ptr ExportDMABufManager -> IO () 26 | 27 | destroyDMAExporter :: ExportDMABufManager -> IO () 28 | destroyDMAExporter (ExportDMABufManager ptr) = c_destroy ptr 29 | -------------------------------------------------------------------------------- /src/Graphics/Wayland/WlRoots/GammaControl.hsc: -------------------------------------------------------------------------------- 1 | module Graphics.Wayland.WlRoots.GammaControl 2 | ( WlrGammaManager 3 | , createGammaManager 4 | , destroyGammaManager 5 | , getGammaGlobal 6 | ) 7 | where 8 | 9 | #define WLR_USE_UNSTABLE 10 | #include 11 | 12 | import Foreign.Ptr (Ptr) 13 | import Foreign.Storable (Storable (..)) 14 | 15 | import Graphics.Wayland.Server (DisplayServer (..)) 16 | import Graphics.Wayland.Global (WlGlobal) 17 | 18 | data WlrGammaManager 19 | 20 | foreign import ccall "wlr_gamma_control_manager_create" c_create :: Ptr DisplayServer -> IO (Ptr WlrGammaManager) 21 | 22 | createGammaManager :: DisplayServer -> IO (Ptr WlrGammaManager) 23 | createGammaManager (DisplayServer ptr) = c_create ptr 24 | 25 | foreign import ccall "wlr_gamma_control_manager_destroy" c_destroy :: Ptr WlrGammaManager -> IO () 26 | 27 | destroyGammaManager :: Ptr WlrGammaManager -> IO () 28 | destroyGammaManager = c_destroy 29 | 30 | getGammaGlobal :: Ptr WlrGammaManager -> IO (Ptr WlGlobal) 31 | getGammaGlobal = #{peek struct wlr_gamma_control_manager, global} 32 | -------------------------------------------------------------------------------- /src/Graphics/Wayland/WlRoots/Global.hs: -------------------------------------------------------------------------------- 1 | module Graphics.Wayland.WlRoots.Global 2 | where 3 | 4 | import Graphics.Wayland.Global (WlGlobal) 5 | import Foreign.Ptr (Ptr) 6 | 7 | class GlobalWrapper a where 8 | getGlobal :: a -> IO (Ptr WlGlobal) 9 | removeGlobal :: a -> IO () 10 | -------------------------------------------------------------------------------- /src/Graphics/Wayland/WlRoots/IdleInhibit.hsc: -------------------------------------------------------------------------------- 1 | module Graphics.Wayland.WlRoots.IdleInhibit 2 | ( IdleInhibitManager (..) 3 | 4 | , idleInhibitCreate 5 | , idleInhibitDestroy 6 | , getIdleInhibitGlobal 7 | , getIdleInhibitSignal 8 | 9 | , IdleInhibitor (..) 10 | , getInhibitorDestroy 11 | , getInhibitorSurface 12 | ) 13 | where 14 | 15 | #define WLR_USE_UNSTABLE 16 | #include 17 | 18 | import Foreign.Ptr (Ptr, plusPtr) 19 | import Foreign.Storable (Storable (..)) 20 | import Foreign.C.Error (throwErrnoIfNull) 21 | 22 | import Graphics.Wayland.Server (DisplayServer(..)) 23 | import Graphics.Wayland.Signal (WlSignal) 24 | import Graphics.Wayland.Global (WlGlobal) 25 | import Graphics.Wayland.WlRoots.Surface (WlrSurface) 26 | 27 | newtype IdleInhibitManager = IdleInhibitManager { unIIM :: Ptr IdleInhibitManager} 28 | 29 | 30 | foreign import ccall "wlr_idle_inhibit_v1_create" c_create :: Ptr DisplayServer -> IO (Ptr IdleInhibitManager) 31 | 32 | idleInhibitCreate :: DisplayServer -> IO IdleInhibitManager 33 | idleInhibitCreate (DisplayServer dsp) = IdleInhibitManager <$> 34 | throwErrnoIfNull "idleInhibitCreate" (c_create dsp) 35 | 36 | foreign import ccall "wlr_idle_inhibit_v1_destroy" c_destroy :: Ptr IdleInhibitManager -> IO () 37 | 38 | idleInhibitDestroy :: IdleInhibitManager -> IO () 39 | idleInhibitDestroy (IdleInhibitManager ptr) = c_destroy ptr 40 | 41 | getIdleInhibitGlobal :: IdleInhibitManager -> IO (Ptr WlGlobal) 42 | getIdleInhibitGlobal = 43 | #{peek struct wlr_idle_inhibit_manager_v1, global} . unIIM 44 | 45 | getIdleInhibitSignal :: IdleInhibitManager -> Ptr (WlSignal IdleInhibitor) 46 | getIdleInhibitSignal = #{ptr struct wlr_idle_inhibit_manager_v1, events.new_inhibitor} . unIIM 47 | 48 | newtype IdleInhibitor = IdleInhibitor { unII :: Ptr IdleInhibitor } deriving (Eq, Ord, Show) 49 | 50 | getInhibitorDestroy :: IdleInhibitor -> Ptr (WlSignal IdleInhibitor) 51 | getInhibitorDestroy = #{ptr struct wlr_idle_inhibitor_v1, events.destroy} . unII 52 | 53 | getInhibitorSurface :: IdleInhibitor -> IO (Ptr WlrSurface) 54 | getInhibitorSurface = #{peek struct wlr_idle_inhibitor_v1, surface} . unII 55 | -------------------------------------------------------------------------------- /src/Graphics/Wayland/WlRoots/Input.hs-boot: -------------------------------------------------------------------------------- 1 | module Graphics.Wayland.WlRoots.Input 2 | ( InputDevice 3 | ) 4 | where 5 | 6 | data InputDevice 7 | -------------------------------------------------------------------------------- /src/Graphics/Wayland/WlRoots/Input.hsc: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE EmptyDataDecls #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | module Graphics.Wayland.WlRoots.Input 4 | ( DeviceType(..) 5 | , deviceTypeToInt 6 | , intToDeviceType 7 | 8 | , ButtonState(..) 9 | , buttonStateToInt 10 | , intToButtonState 11 | 12 | , InputDevice 13 | , inputDeviceType 14 | , getDestroySignal 15 | , getDeviceName 16 | , getCleanDeviceName 17 | ) 18 | where 19 | 20 | #define WLR_USE_UNSTABLE 21 | #include 22 | 23 | import Data.ByteString.Unsafe (unsafePackCString) 24 | import Data.Text (Text) 25 | import Foreign.Ptr (Ptr, castPtr, plusPtr) 26 | import Foreign.C.Types (CInt) 27 | import Foreign.Storable (Storable(..)) 28 | import Graphics.Wayland.Signal (WlSignal) 29 | 30 | import Graphics.Wayland.WlRoots.Input.Keyboard (WlrKeyboard) 31 | import Graphics.Wayland.WlRoots.Input.Pointer (WlrPointer) 32 | import Graphics.Wayland.WlRoots.Input.TabletPad (WlrTabletPad (..)) 33 | import Graphics.Wayland.WlRoots.Input.Tablet (WlrTablet (..)) 34 | import Graphics.Wayland.WlRoots.Input.Touch (WlrTouch) 35 | import Graphics.Wayland.WlRoots.Input.Buttons 36 | 37 | import qualified Data.Text as T 38 | import qualified Data.Text.Encoding as E 39 | 40 | newtype WlrSwitch = WlrSwitch (Ptr WlrSwitch) deriving (Eq, Show) 41 | 42 | data DeviceType 43 | = DeviceKeyboard !(Ptr WlrKeyboard) 44 | | DevicePointer !(Ptr WlrPointer) 45 | | DeviceTouch !(Ptr WlrTouch) 46 | | DeviceTablet !WlrTablet 47 | | DeviceTabletPad !WlrTabletPad 48 | | DeviceSwitch !WlrSwitch 49 | deriving (Eq, Show) 50 | 51 | deviceTypeToInt :: Num a => DeviceType -> a 52 | deviceTypeToInt (DeviceKeyboard _) = #{const WLR_INPUT_DEVICE_KEYBOARD} 53 | deviceTypeToInt (DevicePointer _) = #{const WLR_INPUT_DEVICE_POINTER} 54 | deviceTypeToInt (DeviceTouch _) = #{const WLR_INPUT_DEVICE_TOUCH} 55 | deviceTypeToInt (DeviceTablet _) = #{const WLR_INPUT_DEVICE_TABLET_TOOL} 56 | deviceTypeToInt (DeviceTabletPad _) = #{const WLR_INPUT_DEVICE_TABLET_PAD} 57 | deviceTypeToInt (DeviceSwitch _) = #{const WLR_INPUT_DEVICE_SWITCH} 58 | 59 | intToDeviceType :: (Eq a, Num a, Show a) => a -> Ptr b -> DeviceType 60 | intToDeviceType #{const WLR_INPUT_DEVICE_KEYBOARD} = DeviceKeyboard . castPtr 61 | intToDeviceType #{const WLR_INPUT_DEVICE_POINTER} = DevicePointer . castPtr 62 | intToDeviceType #{const WLR_INPUT_DEVICE_TOUCH} = DeviceTouch . castPtr 63 | intToDeviceType #{const WLR_INPUT_DEVICE_TABLET_TOOL} = DeviceTablet . WlrTablet . castPtr 64 | intToDeviceType #{const WLR_INPUT_DEVICE_TABLET_PAD} = DeviceTabletPad . WlrTabletPad . castPtr 65 | intToDeviceType #{const WLR_INPUT_DEVICE_SWITCH} = DeviceSwitch . WlrSwitch . castPtr 66 | intToDeviceType x = error $ "Got an unknown DeviceType: " ++ show x 67 | 68 | data InputDevice 69 | 70 | inputDeviceType :: Ptr InputDevice -> IO DeviceType 71 | inputDeviceType ptr = do 72 | int :: CInt <- #{peek struct wlr_input_device, type} ptr 73 | devptr <- #{peek struct wlr_input_device, _device} ptr 74 | pure $ intToDeviceType int devptr 75 | 76 | getDestroySignal :: Ptr InputDevice -> Ptr (WlSignal (InputDevice)) 77 | getDestroySignal = #{ptr struct wlr_input_device, events.destroy} 78 | 79 | -- | Get device name + hexadecimal value pointer. This enforces that every 80 | -- device has a unique name for logging/IPC, but isn't deterministic or pretty 81 | getDeviceName :: Ptr InputDevice -> IO Text 82 | getDeviceName ptr = do 83 | name <- fmap E.decodeUtf8 . unsafePackCString =<< #{peek struct wlr_input_device, name} ptr 84 | let pos = T.pack $ ' ':show ptr 85 | pure $ name `T.append` pos 86 | 87 | -- | Get clean device name 88 | getCleanDeviceName :: Ptr InputDevice -> IO Text 89 | getCleanDeviceName ptr = 90 | fmap E.decodeUtf8 . unsafePackCString =<< #{peek struct wlr_input_device, name} ptr 91 | -------------------------------------------------------------------------------- /src/Graphics/Wayland/WlRoots/Input/Buttons.hsc: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | module Graphics.Wayland.WlRoots.Input.Buttons 3 | ( ButtonState(..) 4 | , buttonStateToInt 5 | , intToButtonState 6 | ) 7 | where 8 | 9 | #define WLR_USE_UNSTABLE 10 | #include 11 | 12 | import Foreign.C.Types (CInt) 13 | import Foreign.Ptr (castPtr) 14 | import Foreign.Storable (Storable(..)) 15 | 16 | data ButtonState 17 | = ButtonReleased 18 | | ButtonPressed 19 | deriving (Eq, Show, Read) 20 | 21 | buttonStateToInt :: Num a => ButtonState -> a 22 | buttonStateToInt ButtonReleased = #{const WLR_BUTTON_RELEASED} 23 | buttonStateToInt ButtonPressed = #{const WLR_BUTTON_PRESSED} 24 | 25 | intToButtonState :: (Eq a, Num a, Show a) => a -> ButtonState 26 | intToButtonState #{const WLR_BUTTON_RELEASED} = ButtonReleased 27 | intToButtonState #{const WLR_BUTTON_PRESSED} = ButtonPressed 28 | intToButtonState x = error $ "Got an an unknown ButtonState: " ++ show x 29 | 30 | instance Storable ButtonState where 31 | sizeOf _ = #{size int} 32 | alignment _ = #{alignment int} 33 | peek = fmap (intToButtonState :: CInt -> ButtonState) . peek . castPtr 34 | poke ptr val = poke (castPtr ptr) (buttonStateToInt val :: CInt) 35 | -------------------------------------------------------------------------------- /src/Graphics/Wayland/WlRoots/Input/Keyboard.hsc: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE EmptyDataDecls #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | module Graphics.Wayland.WlRoots.Input.Keyboard 4 | ( WlrKeyboard 5 | , KeyboardSignals (..) 6 | , getKeySignals 7 | , getKeyDataPtr 8 | 9 | , KeyState (..) 10 | , EventKey (..) 11 | 12 | , getKeystate 13 | , getKeymap 14 | 15 | , setKeymap 16 | , keyStateToInt 17 | 18 | , KeyboardModifiers (..) 19 | , getModifierPtr 20 | , readModifiers 21 | 22 | , WlrModifier (..) 23 | , getModifiers 24 | , modifierToNum 25 | , modifiersToField 26 | 27 | , modifierInField 28 | , fieldToModifiers 29 | 30 | , keyStateToButtonState 31 | , keyStateFromButtonState 32 | 33 | , getKeyboardKeys 34 | ) 35 | where 36 | 37 | #define WLR_USE_UNSTABLE 38 | #include 39 | 40 | import Data.Bits ((.&.), (.|.), Bits) 41 | import Foreign.C.Types (CInt(..), CSize) 42 | import Foreign.Storable (Storable(..)) 43 | import Data.Word (Word32) 44 | import Foreign.Ptr (Ptr, plusPtr) 45 | 46 | import Graphics.Wayland.Signal (WlSignal) 47 | import Graphics.Wayland.WlRoots.Input.Buttons 48 | 49 | import Text.XkbCommon.InternalTypes (CKeymap, CKeyboardState) 50 | 51 | data WlrKeyboard 52 | 53 | data KeyboardSignals = KeyboardSignals 54 | { keySignalKey :: Ptr (WlSignal EventKey) 55 | , keySignalModifiers :: Ptr (WlSignal ()) 56 | } 57 | 58 | getKeySignals :: Ptr WlrKeyboard -> KeyboardSignals 59 | getKeySignals ptr = KeyboardSignals 60 | { keySignalKey = #{ptr struct wlr_keyboard, events.key} ptr 61 | , keySignalModifiers = #{ptr struct wlr_keyboard, events.modifiers} ptr 62 | } 63 | 64 | data KeyState 65 | = KeyReleased 66 | | KeyPressed 67 | deriving (Show, Eq) 68 | 69 | keyStateToButtonState :: KeyState -> ButtonState 70 | keyStateToButtonState KeyReleased = ButtonReleased 71 | keyStateToButtonState KeyPressed = ButtonPressed 72 | 73 | keyStateFromButtonState :: ButtonState -> KeyState 74 | keyStateFromButtonState ButtonReleased = KeyReleased 75 | keyStateFromButtonState ButtonPressed = KeyPressed 76 | 77 | getKeyDataPtr :: Ptr WlrKeyboard -> Ptr (Ptr a) 78 | getKeyDataPtr = #{ptr struct wlr_keyboard, data} 79 | 80 | keyStateFromInt :: CInt -> KeyState 81 | keyStateFromInt #{const WLR_KEY_RELEASED} = KeyReleased 82 | keyStateFromInt #{const WLR_KEY_PRESSED} = KeyPressed 83 | keyStateFromInt x = error $ "Got invalid KeyState: " ++ show x 84 | 85 | keyStateToInt :: Num a => KeyState -> a 86 | keyStateToInt KeyReleased = #{const WLR_KEY_RELEASED} 87 | keyStateToInt KeyPressed = #{const WLR_KEY_PRESSED} 88 | 89 | 90 | data EventKey = EventKey 91 | { timeSec :: Word32 92 | , keyCode :: Word32 93 | , state :: KeyState 94 | } 95 | deriving (Show) 96 | 97 | instance Storable EventKey where 98 | sizeOf _ = #{size struct wlr_event_keyboard_key} 99 | alignment _ = #{alignment struct wlr_event_keyboard_key} 100 | peek ptr = EventKey 101 | <$> #{peek struct wlr_event_keyboard_key, time_msec} ptr 102 | <*> #{peek struct wlr_event_keyboard_key, keycode} ptr 103 | <*> (fmap keyStateFromInt . #{peek struct wlr_event_keyboard_key, state}) ptr 104 | poke = error "We don't poke EventKeys" 105 | 106 | foreign import ccall "wlr_keyboard_set_keymap" c_set_keymap :: Ptr WlrKeyboard -> Ptr CKeymap -> IO () 107 | 108 | setKeymap :: Ptr WlrKeyboard -> Ptr CKeymap -> IO () 109 | setKeymap = c_set_keymap 110 | 111 | getKeystate :: Ptr WlrKeyboard -> IO (Ptr CKeyboardState) 112 | getKeystate = #{peek struct wlr_keyboard, xkb_state} 113 | 114 | getKeymap :: Ptr WlrKeyboard -> IO (Ptr CKeymap) 115 | getKeymap = #{peek struct wlr_keyboard, keymap} 116 | 117 | 118 | data KeyboardModifiers = Modifiers 119 | { modDepressed :: Word32 120 | , modLatched :: Word32 121 | , modLocked :: Word32 122 | , modGroup :: Word32 123 | } 124 | 125 | getModifierPtr :: Ptr WlrKeyboard -> Ptr KeyboardModifiers 126 | getModifierPtr = #{ptr struct wlr_keyboard, modifiers} 127 | 128 | readModifiers :: Ptr WlrKeyboard -> IO KeyboardModifiers 129 | readModifiers ptr = Modifiers 130 | <$> #{peek struct wlr_keyboard, modifiers.depressed} ptr 131 | <*> #{peek struct wlr_keyboard, modifiers.latched} ptr 132 | <*> #{peek struct wlr_keyboard, modifiers.locked} ptr 133 | <*> #{peek struct wlr_keyboard, modifiers.group} ptr 134 | 135 | foreign import ccall unsafe "wlr_keyboard_get_modifiers" c_get_modifiers :: Ptr WlrKeyboard -> IO Word32 136 | 137 | getModifiers :: Ptr WlrKeyboard -> IO Word32 138 | getModifiers = c_get_modifiers 139 | 140 | data WlrModifier 141 | = Shift 142 | | Caps 143 | | Ctrl 144 | | Alt 145 | | Mod2 146 | | Mod3 147 | | Logo 148 | | Mod5 149 | deriving (Show, Eq) 150 | 151 | modifierToNum :: Num a => WlrModifier -> a 152 | modifierToNum Shift = #{const WLR_MODIFIER_SHIFT} 153 | modifierToNum Caps = #{const WLR_MODIFIER_CAPS} 154 | modifierToNum Ctrl = #{const WLR_MODIFIER_CTRL} 155 | modifierToNum Alt = #{const WLR_MODIFIER_ALT} 156 | modifierToNum Mod2 = #{const WLR_MODIFIER_MOD2} 157 | modifierToNum Mod3 = #{const WLR_MODIFIER_MOD3} 158 | modifierToNum Logo = #{const WLR_MODIFIER_LOGO} 159 | modifierToNum Mod5 = #{const WLR_MODIFIER_MOD5} 160 | 161 | modifiersToField :: (Num a, Bits a, Foldable t) => t WlrModifier -> a 162 | modifiersToField = foldr ((.|.) . modifierToNum) 0 163 | 164 | modifierInField :: (Num a, Bits a) => WlrModifier -> a -> Bool 165 | modifierInField modifier field = modifierToNum modifier .&. field /= 0 166 | 167 | fieldToModifiers :: (Num a, Bits a) => a -> [WlrModifier] 168 | fieldToModifiers field = 169 | foldr prependIf [] allMods 170 | where prependIf :: WlrModifier -> [WlrModifier] -> [WlrModifier] 171 | prependIf modifier mods = 172 | if modifierInField modifier field 173 | then (modifier:mods) 174 | else mods 175 | allMods :: [WlrModifier] 176 | allMods = [Shift, Caps, Ctrl, Alt, Mod2, Mod3, Logo, Mod5] 177 | 178 | getKeyboardKeys :: Ptr WlrKeyboard -> IO (Ptr Word32, CSize) 179 | getKeyboardKeys ptr = do 180 | let ret = #{ptr struct wlr_keyboard, keycodes} ptr 181 | num <- #{peek struct wlr_keyboard, num_keycodes} ptr 182 | pure (ret, num) 183 | -------------------------------------------------------------------------------- /src/Graphics/Wayland/WlRoots/Input/Pointer.hsc: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | {-# LANGUAGE NumDecimals #-} 3 | module Graphics.Wayland.WlRoots.Input.Pointer 4 | ( WlrPointer 5 | , WlrEventPointerButton (..) 6 | 7 | , pointerGetEvents 8 | , PointerEvents (..) 9 | , WlrEventPointerMotion (..) 10 | , WlrEventPointerAbsMotion (..) 11 | 12 | , AxisSource (..) 13 | , AxisOrientation (..) 14 | , WlrEventPointerAxis (..) 15 | , axisOToInt 16 | ) 17 | where 18 | 19 | #define WLR_USE_UNSTABLE 20 | #include 21 | 22 | import Data.Int (Int32) 23 | import Data.Word (Word32) 24 | import Foreign.C.Types (CInt(..)) 25 | import Foreign.Ptr (Ptr, plusPtr, castPtr) 26 | import Foreign.Storable (Storable(..)) 27 | 28 | import Graphics.Wayland.Signal (WlSignal) 29 | import Graphics.Wayland.WlRoots.Input.Buttons 30 | import {-# SOURCE #-} Graphics.Wayland.WlRoots.Input (InputDevice) 31 | 32 | data PointerEvents = PointerEvents 33 | { pointerButton :: Ptr (WlSignal WlrEventPointerButton) 34 | , pointerMotion :: Ptr (WlSignal WlrEventPointerMotion) 35 | , pointerMotionAbs :: Ptr (WlSignal WlrEventPointerAbsMotion) 36 | , pointerAxis :: Ptr (WlSignal WlrEventPointerAxis) 37 | } 38 | 39 | pointerGetEvents :: Ptr WlrPointer -> PointerEvents 40 | pointerGetEvents ptr = PointerEvents 41 | { pointerButton = #{ptr struct wlr_pointer, events.button} ptr 42 | , pointerMotion = #{ptr struct wlr_pointer, events.motion} ptr 43 | , pointerMotionAbs = #{ptr struct wlr_pointer, events.motion_absolute} ptr 44 | , pointerAxis = #{ptr struct wlr_pointer, events.axis} ptr 45 | } 46 | 47 | data WlrPointer 48 | 49 | data WlrEventPointerButton = WlrEventPointerButton 50 | { eventPointerButtonDevice :: Ptr InputDevice 51 | , eventPointerButtonTime :: Word32 52 | , eventPointerButtonButton :: Word32 53 | , eventPointerButtonState :: ButtonState 54 | } deriving (Show, Eq) 55 | 56 | instance Storable WlrEventPointerButton where 57 | sizeOf _ = #{size struct wlr_event_pointer_button} 58 | alignment _ = #{alignment struct wlr_event_pointer_button} 59 | peek ptr = do 60 | dev <- #{peek struct wlr_event_pointer_button, device} ptr 61 | button <- #{peek struct wlr_event_pointer_button, button} ptr 62 | 63 | state :: CInt <- #{peek struct wlr_event_pointer_button, state} ptr 64 | tsec :: Word32 <- #{peek struct wlr_event_pointer_button, time_msec} ptr 65 | 66 | pure $ WlrEventPointerButton 67 | dev 68 | (fromIntegral tsec) 69 | button 70 | (intToButtonState state) 71 | poke ptr event = do 72 | #{poke struct wlr_event_pointer_button, device} ptr $ eventPointerButtonDevice event 73 | #{poke struct wlr_event_pointer_button, button} ptr $ eventPointerButtonButton event 74 | let state :: CInt = buttonStateToInt $ eventPointerButtonState event 75 | #{poke struct wlr_event_pointer_button, state} ptr state 76 | let tsec :: Word32 = fromIntegral $ eventPointerButtonTime event 77 | #{poke struct wlr_event_pointer_button, time_msec} ptr tsec 78 | 79 | data WlrEventPointerMotion = WlrEventPointerMotion 80 | { eventPointerMotionDevice :: Ptr InputDevice 81 | , eventPointerMotionTime :: Word32 82 | , eventPointerMotionDeltaX :: Double 83 | , eventPointerMotionDeltaY :: Double 84 | } deriving (Show, Eq) 85 | 86 | instance Storable WlrEventPointerMotion where 87 | sizeOf _ = #{size struct wlr_event_pointer_motion} 88 | alignment _ = #{alignment struct wlr_event_pointer_motion} 89 | peek ptr = do 90 | dev <- #{peek struct wlr_event_pointer_motion, device} ptr 91 | tsec :: Word32 <- #{peek struct wlr_event_pointer_motion, time_msec} ptr 92 | deltax <- #{peek struct wlr_event_pointer_motion, delta_x} ptr 93 | deltay <- #{peek struct wlr_event_pointer_motion, delta_y} ptr 94 | 95 | pure $ WlrEventPointerMotion 96 | dev 97 | (fromIntegral tsec) 98 | deltax 99 | deltay 100 | poke ptr event = do 101 | #{poke struct wlr_event_pointer_motion, device} ptr $ eventPointerMotionDevice event 102 | let tsec :: Word32 = fromIntegral $ eventPointerMotionTime event 103 | #{poke struct wlr_event_pointer_motion, time_msec} ptr tsec 104 | 105 | #{poke struct wlr_event_pointer_motion, delta_x} ptr $ eventPointerMotionDeltaX event 106 | #{poke struct wlr_event_pointer_motion, delta_y} ptr $ eventPointerMotionDeltaY event 107 | 108 | 109 | data WlrEventPointerAbsMotion = WlrEventPointerAbsMotion 110 | { eventPointerAbsMotionDevice :: Ptr InputDevice 111 | , eventPointerAbsMotionTime :: Word32 112 | , eventPointerAbsMotionX :: Double 113 | , eventPointerAbsMotionY :: Double 114 | } deriving (Show, Eq) 115 | 116 | instance Storable WlrEventPointerAbsMotion where 117 | sizeOf _ = #{size struct wlr_event_pointer_motion_absolute} 118 | alignment _ = #{alignment struct wlr_event_pointer_motion_absolute} 119 | peek ptr = do 120 | dev <- #{peek struct wlr_event_pointer_motion_absolute, device} ptr 121 | tsec :: Word32 <- #{peek struct wlr_event_pointer_motion_absolute, time_msec} ptr 122 | x <- #{peek struct wlr_event_pointer_motion_absolute, x} ptr 123 | y <- #{peek struct wlr_event_pointer_motion_absolute, y} ptr 124 | 125 | pure $ WlrEventPointerAbsMotion 126 | dev 127 | (fromIntegral tsec) 128 | x 129 | y 130 | 131 | poke ptr event = do 132 | #{poke struct wlr_event_pointer_motion_absolute, device} ptr $ eventPointerAbsMotionDevice event 133 | let tsec :: Word32 = fromIntegral $ eventPointerAbsMotionTime event 134 | #{poke struct wlr_event_pointer_motion_absolute, time_msec} ptr tsec 135 | 136 | #{poke struct wlr_event_pointer_motion_absolute, x} ptr $ eventPointerAbsMotionX event 137 | #{poke struct wlr_event_pointer_motion_absolute, y} ptr $ eventPointerAbsMotionY event 138 | 139 | 140 | data AxisSource 141 | = AxisWheel 142 | | AxisFinger 143 | | AxisContinuous 144 | | AxisWheelTilt 145 | deriving (Show, Eq, Read) 146 | 147 | axisSToInt :: Num a => AxisSource -> a 148 | axisSToInt AxisWheel = #{const WLR_AXIS_SOURCE_WHEEL} 149 | axisSToInt AxisFinger = #{const WLR_AXIS_SOURCE_FINGER} 150 | axisSToInt AxisContinuous = #{const WLR_AXIS_SOURCE_CONTINUOUS} 151 | axisSToInt AxisWheelTilt = #{const WLR_AXIS_SOURCE_WHEEL_TILT} 152 | 153 | intToAxisS :: (Eq a, Num a, Show a) => a -> AxisSource 154 | intToAxisS #{const WLR_AXIS_SOURCE_WHEEL} = AxisWheel 155 | intToAxisS #{const WLR_AXIS_SOURCE_FINGER} = AxisFinger 156 | intToAxisS #{const WLR_AXIS_SOURCE_CONTINUOUS} = AxisContinuous 157 | intToAxisS #{const WLR_AXIS_SOURCE_WHEEL_TILT} = AxisWheelTilt 158 | intToAxisS x = error $ "Got an an unknown PadRingSource: " ++ show x 159 | 160 | instance Storable AxisSource where 161 | sizeOf _ = #{size int} 162 | alignment _ = #{alignment int} 163 | peek = fmap (intToAxisS :: CInt -> AxisSource) . peek . castPtr 164 | poke ptr val = poke (castPtr ptr) (axisSToInt val :: CInt) 165 | 166 | 167 | data AxisOrientation 168 | = AxisVertical 169 | | AxisHorizontal 170 | deriving (Show, Eq, Read) 171 | 172 | axisOToInt :: Num a => AxisOrientation -> a 173 | axisOToInt AxisVertical = #{const WLR_AXIS_ORIENTATION_VERTICAL} 174 | axisOToInt AxisHorizontal = #{const WLR_AXIS_ORIENTATION_HORIZONTAL} 175 | 176 | intToAxisO :: (Eq a, Num a, Show a) => a -> AxisOrientation 177 | intToAxisO #{const WLR_AXIS_ORIENTATION_VERTICAL} = AxisVertical 178 | intToAxisO #{const WLR_AXIS_ORIENTATION_HORIZONTAL} = AxisHorizontal 179 | intToAxisO x = error $ "Got an an unknown PadRingSource: " ++ show x 180 | 181 | instance Storable AxisOrientation where 182 | sizeOf _ = #{size int} 183 | alignment _ = #{alignment int} 184 | peek = fmap (intToAxisO :: CInt -> AxisOrientation) . peek . castPtr 185 | poke ptr val = poke (castPtr ptr) (axisOToInt val :: CInt) 186 | 187 | data WlrEventPointerAxis = WlrEventPointerAxis 188 | { eventPointerAxisDevice :: Ptr InputDevice 189 | , eventPointerAxisTime :: Word32 190 | , eventPointerAxisSource :: AxisSource 191 | , eventPointerAxisOrientation :: AxisOrientation 192 | , eventPointerAxisDelta :: Double 193 | , eventPointerAxisDiscrete :: Int32 194 | } deriving (Show, Eq) 195 | 196 | 197 | 198 | instance Storable WlrEventPointerAxis where 199 | sizeOf _ = #{size struct wlr_event_pointer_axis} 200 | alignment _ = #{alignment struct wlr_event_pointer_axis} 201 | peek ptr = WlrEventPointerAxis 202 | <$> #{peek struct wlr_event_pointer_axis, device} ptr 203 | <*> #{peek struct wlr_event_pointer_axis, time_msec} ptr 204 | <*> #{peek struct wlr_event_pointer_axis, source} ptr 205 | <*> #{peek struct wlr_event_pointer_axis, orientation} ptr 206 | <*> #{peek struct wlr_event_pointer_axis, delta} ptr 207 | <*> #{peek struct wlr_event_pointer_axis, delta_discrete} ptr 208 | poke ptr event = do 209 | #{poke struct wlr_event_pointer_axis, device} ptr $ eventPointerAxisDevice event 210 | #{poke struct wlr_event_pointer_axis, time_msec} ptr $ eventPointerAxisTime event 211 | #{poke struct wlr_event_pointer_axis, source} ptr $ eventPointerAxisSource event 212 | #{poke struct wlr_event_pointer_axis, orientation} ptr $ eventPointerAxisOrientation event 213 | #{poke struct wlr_event_pointer_axis, delta} ptr $ eventPointerAxisDelta event 214 | #{poke struct wlr_event_pointer_axis, delta_discrete} ptr $ eventPointerAxisDiscrete event 215 | -------------------------------------------------------------------------------- /src/Graphics/Wayland/WlRoots/Input/Tablet.hsc: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | module Graphics.Wayland.WlRoots.Input.Tablet 3 | ( WlrTablet (..) 4 | , TabletEvents (..) 5 | , getTabletEvents 6 | 7 | , peekTabletData 8 | , pokeTabletData 9 | 10 | , ToolAxis (..) 11 | , ToolAxisEvent (..) 12 | 13 | , ProximityState (..) 14 | , ToolProximityEvent (..) 15 | 16 | , TipState (..) 17 | , ToolTipEvent (..) 18 | , tipStateToButtonState 19 | 20 | , ToolButtonEvent (..) 21 | ) 22 | where 23 | 24 | #define WLR_USE_UNSTABLE 25 | #include 26 | 27 | import Data.Bits (bit, (.&.)) 28 | import Data.Maybe (catMaybes) 29 | import Data.Word (Word32) 30 | import Foreign.C.Types (CInt) 31 | import Foreign.Ptr (Ptr, plusPtr, castPtr) 32 | import Foreign.Storable 33 | 34 | import Graphics.Wayland.Signal (WlSignal) 35 | import {-# SOURCE #-} Graphics.Wayland.WlRoots.Input (InputDevice) 36 | import Graphics.Wayland.WlRoots.Input.Buttons (ButtonState, intToButtonState) 37 | import Graphics.Wayland.WlRoots.Input.TabletTool (WlrTabletTool (..)) 38 | 39 | newtype WlrTablet = WlrTablet (Ptr WlrTablet) deriving (Eq, Show) 40 | 41 | 42 | peekTabletData :: WlrTablet -> IO (Ptr a) 43 | peekTabletData (WlrTablet ptr) = #{peek struct wlr_tablet, data} ptr 44 | 45 | pokeTabletData :: WlrTablet -> Ptr a -> IO () 46 | pokeTabletData (WlrTablet ptr) = #{poke struct wlr_tablet, data} ptr 47 | 48 | 49 | data TabletEvents = TabletEvents 50 | { tabletEventAxis :: Ptr (WlSignal ToolAxisEvent) 51 | , tabletEventProximity :: Ptr (WlSignal ToolProximityEvent) 52 | , tabletEventTip :: Ptr (WlSignal ToolTipEvent) 53 | , tabletEventButton :: Ptr (WlSignal ToolButtonEvent) 54 | } 55 | 56 | 57 | getTabletEvents :: WlrTablet -> TabletEvents 58 | getTabletEvents (WlrTablet ptr) = TabletEvents 59 | { tabletEventAxis = #{ptr struct wlr_tablet, events.axis} ptr 60 | , tabletEventProximity = #{ptr struct wlr_tablet, events.proximity} ptr 61 | , tabletEventTip = #{ptr struct wlr_tablet, events.tip} ptr 62 | , tabletEventButton = #{ptr struct wlr_tablet, events.button} ptr 63 | } 64 | 65 | data ToolAxis 66 | = AxisX Double 67 | | AxisY Double 68 | | AxisDistance Double 69 | | AxisPressure Double 70 | | AxisTiltX Double 71 | | AxisTiltY Double 72 | | AxisRotation Double 73 | | AxisSlider Double 74 | | AxisWheel Double 75 | deriving (Eq, Show, Read) 76 | 77 | _toolAxisToInt :: Num a => ToolAxis -> a 78 | _toolAxisToInt (AxisX _) = #{const WLR_TABLET_TOOL_AXIS_X} 79 | _toolAxisToInt (AxisY _) = #{const WLR_TABLET_TOOL_AXIS_Y} 80 | _toolAxisToInt (AxisDistance _) = #{const WLR_TABLET_TOOL_AXIS_DISTANCE} 81 | _toolAxisToInt (AxisPressure _) = #{const WLR_TABLET_TOOL_AXIS_PRESSURE} 82 | _toolAxisToInt (AxisTiltX _) = #{const WLR_TABLET_TOOL_AXIS_TILT_X} 83 | _toolAxisToInt (AxisTiltY _) = #{const WLR_TABLET_TOOL_AXIS_TILT_Y} 84 | _toolAxisToInt (AxisRotation _) = #{const WLR_TABLET_TOOL_AXIS_ROTATION} 85 | _toolAxisToInt (AxisSlider _) = #{const WLR_TABLET_TOOL_AXIS_SLIDER} 86 | _toolAxisToInt (AxisWheel _) = #{const WLR_TABLET_TOOL_AXIS_WHEEL} 87 | 88 | readToolAxis :: (Eq a, Num a) => a -> Ptr ToolAxisEvent -> Maybe (IO ToolAxis) 89 | readToolAxis #{const WLR_TABLET_TOOL_AXIS_X} ptr = Just $ AxisX 90 | <$> #{peek struct wlr_event_tablet_tool_axis, x} ptr 91 | readToolAxis #{const WLR_TABLET_TOOL_AXIS_Y} ptr = Just $ AxisY 92 | <$> #{peek struct wlr_event_tablet_tool_axis, y} ptr 93 | readToolAxis #{const WLR_TABLET_TOOL_AXIS_DISTANCE} ptr = Just $ AxisDistance 94 | <$> #{peek struct wlr_event_tablet_tool_axis, distance} ptr 95 | readToolAxis #{const WLR_TABLET_TOOL_AXIS_PRESSURE} ptr = Just $ AxisPressure 96 | <$> #{peek struct wlr_event_tablet_tool_axis, pressure} ptr 97 | readToolAxis #{const WLR_TABLET_TOOL_AXIS_TILT_X} ptr = Just $ AxisTiltX 98 | <$> #{peek struct wlr_event_tablet_tool_axis, tilt_x} ptr 99 | readToolAxis #{const WLR_TABLET_TOOL_AXIS_TILT_Y} ptr = Just $ AxisTiltY 100 | <$> #{peek struct wlr_event_tablet_tool_axis, tilt_y} ptr 101 | readToolAxis #{const WLR_TABLET_TOOL_AXIS_ROTATION} ptr = Just $ AxisRotation 102 | <$> #{peek struct wlr_event_tablet_tool_axis, rotation} ptr 103 | readToolAxis #{const WLR_TABLET_TOOL_AXIS_SLIDER} ptr = Just $ AxisSlider 104 | <$> #{peek struct wlr_event_tablet_tool_axis, slider} ptr 105 | readToolAxis #{const WLR_TABLET_TOOL_AXIS_WHEEL} ptr = Just $ AxisWheel 106 | <$> #{peek struct wlr_event_tablet_tool_axis, wheel_delta} ptr 107 | readToolAxis _ _ = Nothing 108 | 109 | data ToolAxisEvent = ToolAxisEvent 110 | { toolAxisEvtTime :: Word32 111 | , toolAxisEvtAxes :: [ToolAxis] 112 | , toolAxisEvtDevice :: Ptr InputDevice 113 | , toolAxisEvtTool :: WlrTabletTool 114 | } deriving (Show) 115 | 116 | instance Storable ToolAxisEvent where 117 | sizeOf _ = #{size struct wlr_event_tablet_tool_axis} 118 | alignment _ = #{alignment struct wlr_event_tablet_tool_axis} 119 | peek ptr = do 120 | device <- #{peek struct wlr_event_tablet_tool_axis, device} ptr 121 | time <- #{peek struct wlr_event_tablet_tool_axis, time_msec} ptr 122 | axesEnum :: CInt <- #{peek struct wlr_event_tablet_tool_axis, updated_axes} ptr 123 | axes <- sequence . catMaybes . flip fmap [0..8] $ \index -> 124 | readToolAxis (bit index .&. axesEnum) ptr 125 | tool <- WlrTabletTool <$> #{peek struct wlr_event_tablet_tool_axis, tool} ptr 126 | pure $ ToolAxisEvent 127 | { toolAxisEvtTime = time 128 | , toolAxisEvtAxes = axes 129 | , toolAxisEvtDevice = device 130 | , toolAxisEvtTool = tool 131 | } 132 | poke _ _ = error "We don't poke ToolAxisEvents for now" 133 | 134 | data ProximityState 135 | = ProximityIn 136 | | ProximityOut 137 | deriving (Show, Eq, Read) 138 | 139 | proximityStateToInt :: Num a => ProximityState -> a 140 | proximityStateToInt ProximityIn = #{const WLR_TABLET_TOOL_PROXIMITY_OUT} 141 | proximityStateToInt ProximityOut = #{const WLR_TABLET_TOOL_PROXIMITY_IN } 142 | 143 | intToProximityState :: (Eq a, Num a, Show a) => a -> ProximityState 144 | intToProximityState #{const WLR_TABLET_TOOL_PROXIMITY_OUT} = ProximityIn 145 | intToProximityState #{const WLR_TABLET_TOOL_PROXIMITY_IN } = ProximityOut 146 | intToProximityState x = error $ "Got an an unknown PadRingSource: " ++ show x 147 | 148 | instance Storable ProximityState where 149 | sizeOf _ = #{size int} 150 | alignment _ = #{alignment int} 151 | peek = fmap (intToProximityState :: CInt -> ProximityState) . peek . castPtr 152 | poke ptr val = poke (castPtr ptr) (proximityStateToInt val :: CInt) 153 | 154 | data ToolProximityEvent = ToolProximityEvent 155 | { toolProximityEvtDevice :: Ptr InputDevice 156 | , toolProximityEvtTime :: Word32 157 | , toolProximityEvtX :: Double 158 | , toolProximityEvtY :: Double 159 | , toolProximityEvtState :: ProximityState 160 | , toolProximityEvtTool :: WlrTabletTool 161 | } deriving (Show) 162 | 163 | instance Storable ToolProximityEvent where 164 | sizeOf _ = #{size struct wlr_event_tablet_tool_proximity} 165 | alignment _ = #{alignment struct wlr_event_tablet_tool_proximity} 166 | peek ptr = ToolProximityEvent 167 | <$> #{peek struct wlr_event_tablet_tool_proximity, device} ptr 168 | <*> #{peek struct wlr_event_tablet_tool_proximity, time_msec} ptr 169 | <*> #{peek struct wlr_event_tablet_tool_proximity, x} ptr 170 | <*> #{peek struct wlr_event_tablet_tool_proximity, y} ptr 171 | <*> #{peek struct wlr_event_tablet_tool_proximity, state} ptr 172 | <*> (WlrTabletTool <$> #{peek struct wlr_event_tablet_tool_proximity, tool} ptr) 173 | poke _ _ = error "We don't poke ToolProximityEvents for now" 174 | 175 | 176 | data TipState 177 | = TipUp 178 | | TipDown 179 | deriving (Show, Eq, Read) 180 | 181 | tipStateToInt :: Num a => TipState -> a 182 | tipStateToInt TipUp = #{const WLR_TABLET_TOOL_TIP_UP} 183 | tipStateToInt TipDown = #{const WLR_TABLET_TOOL_TIP_DOWN } 184 | 185 | intToTipState :: (Eq a, Num a, Show a) => a -> TipState 186 | intToTipState #{const WLR_TABLET_TOOL_TIP_UP} = TipUp 187 | intToTipState #{const WLR_TABLET_TOOL_TIP_DOWN} = TipDown 188 | intToTipState x = error $ "Got an an unknown PadRingSource: " ++ show x 189 | 190 | tipStateToButtonState :: TipState -> ButtonState 191 | tipStateToButtonState state = intToButtonState (tipStateToInt state :: Int) 192 | 193 | instance Storable TipState where 194 | sizeOf _ = #{size int} 195 | alignment _ = #{alignment int} 196 | peek = fmap (intToTipState :: CInt -> TipState) . peek . castPtr 197 | poke ptr val = poke (castPtr ptr) (tipStateToInt val :: CInt) 198 | 199 | 200 | data ToolTipEvent = ToolTipEvent 201 | { toolTipEvtDevice :: Ptr InputDevice 202 | , toolTipEvtTime :: Word32 203 | , toolTipEvtX :: Double 204 | , toolTipEvtY :: Double 205 | , toolTipEvtState :: TipState 206 | , toolTipEvtTool :: WlrTabletTool 207 | } deriving (Show) 208 | 209 | instance Storable ToolTipEvent where 210 | sizeOf _ = #{size struct wlr_event_tablet_tool_tip} 211 | alignment _ = #{alignment struct wlr_event_tablet_tool_tip} 212 | peek ptr = ToolTipEvent 213 | <$> #{peek struct wlr_event_tablet_tool_tip, device} ptr 214 | <*> #{peek struct wlr_event_tablet_tool_tip, time_msec} ptr 215 | <*> #{peek struct wlr_event_tablet_tool_tip, x} ptr 216 | <*> #{peek struct wlr_event_tablet_tool_tip, y} ptr 217 | <*> #{peek struct wlr_event_tablet_tool_tip, state} ptr 218 | <*> (WlrTabletTool <$> #{peek struct wlr_event_tablet_tool_tip, tool} ptr) 219 | poke _ _ = error "We don't poke ToolTipEvents for now" 220 | 221 | data ToolButtonEvent = ToolButtonEvent 222 | { toolButtonEvtDevice :: Ptr InputDevice 223 | , toolButtonEvtTime :: Word32 224 | , toolButtonEvtButton :: Word32 225 | , toolButtonEvtState :: ButtonState 226 | , toolButtonEvtTool :: WlrTabletTool 227 | } deriving (Show) 228 | 229 | instance Storable ToolButtonEvent where 230 | sizeOf _ = #{size struct wlr_event_tablet_tool_button} 231 | alignment _ = #{alignment struct wlr_event_tablet_tool_button} 232 | peek ptr = ToolButtonEvent 233 | <$> #{peek struct wlr_event_tablet_tool_button, device} ptr 234 | <*> #{peek struct wlr_event_tablet_tool_button, time_msec} ptr 235 | <*> #{peek struct wlr_event_tablet_tool_button, button} ptr 236 | <*> #{peek struct wlr_event_tablet_tool_button, state} ptr 237 | <*> (WlrTabletTool <$> #{peek struct wlr_event_tablet_tool_button, tool} ptr) 238 | poke ptr evt = do 239 | #{poke struct wlr_event_tablet_tool_button, device} ptr $ toolButtonEvtDevice evt 240 | #{poke struct wlr_event_tablet_tool_button, time_msec} ptr $ toolButtonEvtTime evt 241 | #{poke struct wlr_event_tablet_tool_button, button} ptr $ toolButtonEvtButton evt 242 | #{poke struct wlr_event_tablet_tool_button, state} ptr $ toolButtonEvtState evt 243 | #{poke struct wlr_event_tablet_tool_button, tool} ptr $ unWlrTabletTool $ toolButtonEvtTool evt 244 | 245 | -------------------------------------------------------------------------------- /src/Graphics/Wayland/WlRoots/Input/TabletPad.hsc: -------------------------------------------------------------------------------- 1 | module Graphics.Wayland.WlRoots.Input.TabletPad 2 | ( WlrTabletPad (..) 3 | , PadEvents (..) 4 | , getPadEvents 5 | , peekPadData 6 | , pokePadData 7 | 8 | , PadButtonEvent (..) 9 | 10 | , PadRingSource (..) 11 | , PadRingEvent (..) 12 | 13 | , PadStripSource (..) 14 | , PadStripEvent (..) 15 | ) 16 | where 17 | 18 | #define WLR_USE_UNSTABLE 19 | #include 20 | 21 | import Data.Word (Word32) 22 | import Foreign.C.Types (CInt) 23 | import Foreign.Ptr (Ptr, plusPtr, castPtr) 24 | import Foreign.Storable 25 | 26 | import Graphics.Wayland.Signal (WlSignal) 27 | 28 | -- import {-# SOURCE #-} Graphics.Wayland.WlRoots.Input (InputDevice) 29 | import Graphics.Wayland.WlRoots.Input.Buttons 30 | import Graphics.Wayland.WlRoots.Input.Tablet (WlrTablet) 31 | 32 | newtype WlrTabletPad = WlrTabletPad (Ptr WlrTabletPad) deriving (Eq, Show) 33 | 34 | data PadEvents = PadEvents 35 | { padEventButton :: Ptr (WlSignal PadButtonEvent) 36 | , padEventRing :: Ptr (WlSignal PadRingEvent) 37 | , padEventStrip :: Ptr (WlSignal PadStripEvent) 38 | , padEventAttach :: Ptr (WlSignal WlrTablet) 39 | } 40 | 41 | 42 | getPadEvents :: WlrTabletPad -> PadEvents 43 | getPadEvents (WlrTabletPad ptr) = PadEvents 44 | { padEventButton = #{ptr struct wlr_tablet_pad, events.button} ptr 45 | , padEventRing = #{ptr struct wlr_tablet_pad, events.ring} ptr 46 | , padEventStrip = #{ptr struct wlr_tablet_pad, events.strip} ptr 47 | , padEventAttach = #{ptr struct wlr_tablet_pad, events.attach_tablet} ptr 48 | } 49 | 50 | peekPadData :: WlrTabletPad -> IO (Ptr a) 51 | peekPadData (WlrTabletPad ptr) = #{peek struct wlr_tablet_pad, data} ptr 52 | 53 | pokePadData :: WlrTabletPad -> Ptr a -> IO () 54 | pokePadData (WlrTabletPad ptr) = #{poke struct wlr_tablet_pad, data} ptr 55 | 56 | data PadButtonEvent = PadButtonEvent 57 | { padButtonEvtTime :: Word32 58 | , padButtonEvtButton :: Word32 59 | , padButtonEvtState :: ButtonState 60 | , padButtonEvtMode :: CInt 61 | , padButtonEvtGroup :: CInt 62 | } deriving (Show) 63 | 64 | instance Storable PadButtonEvent where 65 | sizeOf _ = #{size struct wlr_event_tablet_pad_button} 66 | alignment _ = #{alignment struct wlr_event_tablet_pad_button} 67 | peek ptr = PadButtonEvent 68 | <$> #{peek struct wlr_event_tablet_pad_button, time_msec} ptr 69 | <*> #{peek struct wlr_event_tablet_pad_button, button} ptr 70 | <*> #{peek struct wlr_event_tablet_pad_button, state} ptr 71 | <*> #{peek struct wlr_event_tablet_pad_button, mode} ptr 72 | <*> #{peek struct wlr_event_tablet_pad_button, group} ptr 73 | poke ptr evt = do 74 | #{poke struct wlr_event_tablet_pad_button, time_msec} ptr $ padButtonEvtTime evt 75 | #{poke struct wlr_event_tablet_pad_button, button} ptr $ padButtonEvtButton evt 76 | #{poke struct wlr_event_tablet_pad_button, state} ptr $ padButtonEvtState evt 77 | #{poke struct wlr_event_tablet_pad_button, mode} ptr $ padButtonEvtMode evt 78 | #{poke struct wlr_event_tablet_pad_button, group} ptr $ padButtonEvtGroup evt 79 | 80 | data PadRingSource 81 | = RingSourceUnknown 82 | | RingSourceFinger 83 | deriving (Show, Eq, Read) 84 | 85 | ringSourceToInt :: Num a => PadRingSource -> a 86 | ringSourceToInt RingSourceUnknown = #{const WLR_TABLET_PAD_RING_SOURCE_UNKNOWN} 87 | ringSourceToInt RingSourceFinger = #{const WLR_TABLET_PAD_RING_SOURCE_FINGER} 88 | 89 | intToRingSource :: (Eq a, Num a, Show a) => a -> PadRingSource 90 | intToRingSource #{const WLR_TABLET_PAD_RING_SOURCE_UNKNOWN} = RingSourceUnknown 91 | intToRingSource #{const WLR_TABLET_PAD_RING_SOURCE_FINGER} = RingSourceFinger 92 | intToRingSource x = error $ "Got an an unknown PadRingSource: " ++ show x 93 | 94 | instance Storable PadRingSource where 95 | sizeOf _ = #{size int} 96 | alignment _ = #{alignment int} 97 | peek = fmap (intToRingSource :: CInt -> PadRingSource) . peek . castPtr 98 | poke ptr val = poke (castPtr ptr) (ringSourceToInt val :: CInt) 99 | 100 | data PadRingEvent = PadRingEvent 101 | { padRingEvtTime :: Word32 102 | , padRingEvtSource :: PadRingSource 103 | , padRingEvtRing :: Word32 104 | , padRingEvtPosition :: Double 105 | , padRingEvtMode :: CInt 106 | } deriving (Show) 107 | 108 | instance Storable PadRingEvent where 109 | sizeOf _ = #{size struct wlr_event_tablet_pad_ring} 110 | alignment _ = #{alignment struct wlr_event_tablet_pad_ring} 111 | peek ptr = PadRingEvent 112 | <$> #{peek struct wlr_event_tablet_pad_ring, time_msec} ptr 113 | <*> #{peek struct wlr_event_tablet_pad_ring, source} ptr 114 | <*> #{peek struct wlr_event_tablet_pad_ring, ring} ptr 115 | <*> #{peek struct wlr_event_tablet_pad_ring, position} ptr 116 | <*> #{peek struct wlr_event_tablet_pad_ring, mode} ptr 117 | poke ptr evt = do 118 | #{poke struct wlr_event_tablet_pad_ring, time_msec} ptr $ padRingEvtTime evt 119 | #{poke struct wlr_event_tablet_pad_ring, source} ptr $ padRingEvtSource evt 120 | #{poke struct wlr_event_tablet_pad_ring, ring} ptr $ padRingEvtRing evt 121 | #{poke struct wlr_event_tablet_pad_ring, position} ptr $ padRingEvtPosition evt 122 | #{poke struct wlr_event_tablet_pad_ring, mode} ptr $ padRingEvtMode evt 123 | 124 | data PadStripSource 125 | = StripSourceUnknown 126 | | StripSourceFinger 127 | deriving (Show, Eq, Read) 128 | 129 | stripSourceToInt :: Num a => PadStripSource -> a 130 | stripSourceToInt StripSourceUnknown = #{const WLR_TABLET_PAD_STRIP_SOURCE_UNKNOWN} 131 | stripSourceToInt StripSourceFinger = #{const WLR_TABLET_PAD_STRIP_SOURCE_FINGER} 132 | 133 | intToStripSource :: (Eq a, Num a, Show a) => a -> PadStripSource 134 | intToStripSource #{const WLR_TABLET_PAD_STRIP_SOURCE_UNKNOWN} = StripSourceUnknown 135 | intToStripSource #{const WLR_TABLET_PAD_STRIP_SOURCE_FINGER} = StripSourceFinger 136 | intToStripSource x = error $ "Got an an unknown PadStripSource: " ++ show x 137 | 138 | instance Storable PadStripSource where 139 | sizeOf _ = #{size int} 140 | alignment _ = #{alignment int} 141 | peek = fmap (intToStripSource :: CInt -> PadStripSource) . peek . castPtr 142 | poke ptr val = poke (castPtr ptr) (stripSourceToInt val :: CInt) 143 | 144 | data PadStripEvent = PadStripEvent 145 | { padStripEvtTime :: Word32 146 | , padStripEvtSource :: PadStripSource 147 | , padStripEvtStrip :: Word32 148 | , padStripEvtPosition :: Double 149 | , padStripEvtMode :: CInt 150 | } deriving (Show) 151 | 152 | instance Storable PadStripEvent where 153 | sizeOf _ = #{size struct wlr_event_tablet_pad_strip} 154 | alignment _ = #{alignment struct wlr_event_tablet_pad_strip} 155 | peek ptr = PadStripEvent 156 | <$> #{peek struct wlr_event_tablet_pad_strip, time_msec} ptr 157 | <*> #{peek struct wlr_event_tablet_pad_strip, source} ptr 158 | <*> #{peek struct wlr_event_tablet_pad_strip, strip} ptr 159 | <*> #{peek struct wlr_event_tablet_pad_strip, position} ptr 160 | <*> #{peek struct wlr_event_tablet_pad_strip, mode} ptr 161 | poke ptr evt = do 162 | #{poke struct wlr_event_tablet_pad_strip, time_msec} ptr $ padStripEvtTime evt 163 | #{poke struct wlr_event_tablet_pad_strip, source} ptr $ padStripEvtSource evt 164 | #{poke struct wlr_event_tablet_pad_strip, strip} ptr $ padStripEvtStrip evt 165 | #{poke struct wlr_event_tablet_pad_strip, position} ptr $ padStripEvtPosition evt 166 | #{poke struct wlr_event_tablet_pad_strip, mode} ptr $ padStripEvtMode evt 167 | -------------------------------------------------------------------------------- /src/Graphics/Wayland/WlRoots/Input/TabletTool.hsc: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | module Graphics.Wayland.WlRoots.Input.TabletTool 3 | ( WlrTabletTool (..) 4 | 5 | , peekTabletToolData 6 | , pokeTabletToolData 7 | 8 | , TabletToolEvents (..) 9 | , getTabletToolEvents 10 | ) 11 | where 12 | 13 | #define WLR_USE_UNSTABLE 14 | #include 15 | 16 | import Foreign.Ptr (Ptr, plusPtr) 17 | import Foreign.Storable 18 | 19 | import Graphics.Wayland.Signal (WlSignal) 20 | 21 | newtype WlrTabletTool = WlrTabletTool {unWlrTabletTool :: Ptr WlrTabletTool} deriving (Eq, Show) 22 | 23 | 24 | peekTabletToolData :: WlrTabletTool -> IO (Ptr a) 25 | peekTabletToolData (WlrTabletTool ptr) = #{peek struct wlr_tablet_tool, data} ptr 26 | 27 | pokeTabletToolData :: WlrTabletTool -> Ptr a -> IO () 28 | pokeTabletToolData (WlrTabletTool ptr) = #{poke struct wlr_tablet_tool, data} ptr 29 | 30 | 31 | newtype TabletToolEvents = TabletToolEvents 32 | { tabletToolEventDestroy :: Ptr (WlSignal WlrTabletTool) } 33 | 34 | 35 | getTabletToolEvents :: WlrTabletTool -> TabletToolEvents 36 | getTabletToolEvents (WlrTabletTool ptr) = TabletToolEvents 37 | { tabletToolEventDestroy = #{ptr struct wlr_tablet_tool, events.destroy} ptr 38 | } 39 | -------------------------------------------------------------------------------- /src/Graphics/Wayland/WlRoots/Input/Touch.hsc: -------------------------------------------------------------------------------- 1 | module Graphics.Wayland.WlRoots.Input.Touch 2 | ( WlrTouch (..) 3 | , WlrTouchEvents (..) 4 | , getWlrTouchEvents 5 | 6 | , WlrTouchDown (..) 7 | , WlrTouchUp (..) 8 | , WlrTouchMotion (..) 9 | , WlrTouchCancel (..) 10 | ) 11 | where 12 | 13 | #define WLR_USE_UNSTABLE 14 | #include 15 | 16 | import Data.Int (Int32) 17 | import Data.Word (Word32) 18 | import Foreign.Ptr (Ptr, plusPtr) 19 | import Foreign.Storable (Storable (..)) 20 | 21 | import Graphics.Wayland.Signal (WlSignal) 22 | 23 | import {-# SOURCE #-} Graphics.Wayland.WlRoots.Input (InputDevice) 24 | 25 | newtype WlrTouch = WlrTouch { unTouch :: Ptr WlrTouch } 26 | 27 | data WlrTouchEvents = WlrTouchEvents 28 | { wlrTouchEvtDown :: {-# UNPACK #-} !(Ptr (WlSignal WlrTouchDown)) 29 | , wlrTouchEvtUp :: {-# UNPACK #-} !(Ptr (WlSignal WlrTouchUp)) 30 | , wlrTouchEvtMotion :: {-# UNPACK #-} !(Ptr (WlSignal WlrTouchMotion)) 31 | , wlrTouchEvtCancel :: {-# UNPACK #-} !(Ptr (WlSignal WlrTouchCancel)) 32 | } 33 | 34 | getWlrTouchEvents :: WlrTouch -> WlrTouchEvents 35 | getWlrTouchEvents (WlrTouch ptr) = WlrTouchEvents 36 | { wlrTouchEvtDown = #{ptr struct wlr_touch, events.down} ptr 37 | , wlrTouchEvtUp = #{ptr struct wlr_touch, events.up} ptr 38 | , wlrTouchEvtCancel = #{ptr struct wlr_touch, events.cancel} ptr 39 | , wlrTouchEvtMotion = #{ptr struct wlr_touch, events.motion} ptr 40 | } 41 | 42 | data WlrTouchDown = WlrTouchDown 43 | { wlrTouchDownDev :: {-# UNPACK #-} !(Ptr InputDevice) 44 | , wlrTouchDownMSec :: {-# UNPACK #-} !Word32 45 | , wlrTouchDownId :: {-# UNPACK #-} !Int32 46 | , wlrTouchDownX :: {-# UNPACK #-} !Double 47 | , wlrTouchDownY :: {-# UNPACK #-} !Double 48 | } deriving (Show) 49 | 50 | instance Storable WlrTouchDown where 51 | sizeOf _ = #{size struct wlr_event_touch_down} 52 | alignment _ = #{alignment struct wlr_event_touch_down} 53 | peek ptr = WlrTouchDown 54 | <$> #{peek struct wlr_event_touch_down, device} ptr 55 | <*> #{peek struct wlr_event_touch_down, time_msec} ptr 56 | <*> #{peek struct wlr_event_touch_down, touch_id} ptr 57 | <*> #{peek struct wlr_event_touch_down, x} ptr 58 | <*> #{peek struct wlr_event_touch_down, y} ptr 59 | poke _ _ = error "We don't poke events (for now)" 60 | 61 | data WlrTouchUp = WlrTouchUp 62 | { wlrTouchUpDev :: {-# UNPACK #-} !(Ptr InputDevice) 63 | , wlrTouchUpMSec :: {-# UNPACK #-} !Word32 64 | , wlrTouchUpId :: {-# UNPACK #-} !Int32 65 | } deriving (Show) 66 | 67 | instance Storable WlrTouchUp where 68 | sizeOf _ = #{size struct wlr_event_touch_up} 69 | alignment _ = #{alignment struct wlr_event_touch_up} 70 | peek ptr = WlrTouchUp 71 | <$> #{peek struct wlr_event_touch_down, device} ptr 72 | <*> #{peek struct wlr_event_touch_down, time_msec} ptr 73 | <*> #{peek struct wlr_event_touch_down, touch_id} ptr 74 | poke _ _ = error "We don't poke events (for now)" 75 | 76 | data WlrTouchMotion = WlrTouchMotion 77 | { wlrTouchMotionDev :: {-# UNPACK #-} !(Ptr InputDevice) 78 | , wlrTouchMotionMSec :: {-# UNPACK #-} !Word32 79 | , wlrTouchMotionId :: {-# UNPACK #-} !Int32 80 | , wlrTouchMotionX :: {-# UNPACK #-} !Double 81 | , wlrTouchMotionY :: {-# UNPACK #-} !Double 82 | } deriving (Show) 83 | 84 | instance Storable WlrTouchMotion where 85 | sizeOf _ = #{size struct wlr_event_touch_motion} 86 | alignment _ = #{alignment struct wlr_event_touch_motion} 87 | peek ptr = WlrTouchMotion 88 | <$> #{peek struct wlr_event_touch_motion, device} ptr 89 | <*> #{peek struct wlr_event_touch_motion, time_msec} ptr 90 | <*> #{peek struct wlr_event_touch_motion, touch_id} ptr 91 | <*> #{peek struct wlr_event_touch_motion, x} ptr 92 | <*> #{peek struct wlr_event_touch_motion, y} ptr 93 | poke _ _ = error "We don't poke events (for now)" 94 | 95 | 96 | data WlrTouchCancel = WlrTouchCancel 97 | { wlrTouchCancelDev :: {-# UNPACK #-} !(Ptr InputDevice) 98 | , wlrTouchCancelMSec :: {-# UNPACK #-} !Word32 99 | , wlrTouchCancelId :: {-# UNPACK #-} !Int32 100 | } deriving (Show) 101 | 102 | instance Storable WlrTouchCancel where 103 | sizeOf _ = #{size struct wlr_event_touch_cancel} 104 | alignment _ = #{alignment struct wlr_event_touch_cancel} 105 | peek ptr = WlrTouchCancel 106 | <$> #{peek struct wlr_event_touch_cancel, device} ptr 107 | <*> #{peek struct wlr_event_touch_cancel, time_msec} ptr 108 | <*> #{peek struct wlr_event_touch_cancel, touch_id} ptr 109 | poke _ _ = error "We don't poke events (for now)" 110 | -------------------------------------------------------------------------------- /src/Graphics/Wayland/WlRoots/InputInhibitor.hsc: -------------------------------------------------------------------------------- 1 | module Graphics.Wayland.WlRoots.InputInhibitor 2 | ( WlrInputInhibitor (..) 3 | , createInputInhibitor 4 | , destroyInputInhibitor 5 | 6 | , getInhibitClient 7 | , WlrInputInhibitEvents (..) 8 | , getInputInhibitorEvents 9 | , getInputInhibitGlobal 10 | ) 11 | where 12 | 13 | #define WLR_USE_UNSTABLE 14 | #include 15 | 16 | import Foreign.C.Error (throwErrnoIfNull) 17 | import Foreign.Ptr (Ptr, nullPtr, plusPtr) 18 | import Foreign.Storable (Storable (..)) 19 | 20 | import Graphics.Wayland.Server (DisplayServer (..), Client (..)) 21 | import Graphics.Wayland.Signal (WlSignal) 22 | import Graphics.Wayland.Global (WlGlobal) 23 | 24 | data WlrInputInhibitor = WlrInputInhibitor (Ptr WlrInputInhibitor) 25 | 26 | foreign import ccall unsafe "wlr_input_inhibit_manager_create" c_create :: Ptr DisplayServer -> IO (Ptr WlrInputInhibitor) 27 | 28 | createInputInhibitor :: DisplayServer -> IO WlrInputInhibitor 29 | createInputInhibitor (DisplayServer dsp) = WlrInputInhibitor <$> 30 | throwErrnoIfNull "createInputInhibitor" (c_create dsp) 31 | 32 | foreign import ccall unsafe "wlr_input_inhibit_manager_destroy" c_destroy :: Ptr WlrInputInhibitor -> IO () 33 | 34 | 35 | destroyInputInhibitor :: WlrInputInhibitor -> IO () 36 | destroyInputInhibitor (WlrInputInhibitor ptr) = c_destroy ptr 37 | 38 | getInhibitClient :: WlrInputInhibitor -> IO (Maybe Client) 39 | getInhibitClient (WlrInputInhibitor ptr) = do 40 | ret <- #{peek struct wlr_input_inhibit_manager, active_client} ptr 41 | pure $ if ret == nullPtr 42 | then Nothing 43 | else Just $ Client ret 44 | 45 | data WlrInputInhibitEvents = WlrInputInhibitEvents 46 | { inputInhibitEventsActivate :: Ptr (WlSignal WlrInputInhibitor) 47 | , inputInhibitEventsDeactivate :: Ptr (WlSignal WlrInputInhibitor) 48 | } 49 | 50 | getInputInhibitorEvents :: WlrInputInhibitor -> WlrInputInhibitEvents 51 | getInputInhibitorEvents (WlrInputInhibitor ptr) = WlrInputInhibitEvents 52 | { inputInhibitEventsActivate = #{ptr struct wlr_input_inhibit_manager, events.activate} ptr 53 | , inputInhibitEventsDeactivate = #{ptr struct wlr_input_inhibit_manager, events.deactivate} ptr 54 | } 55 | 56 | getInputInhibitGlobal :: WlrInputInhibitor -> IO (Ptr WlGlobal) 57 | getInputInhibitGlobal (WlrInputInhibitor ptr) = 58 | #{peek struct wlr_input_inhibit_manager, global} ptr 59 | -------------------------------------------------------------------------------- /src/Graphics/Wayland/WlRoots/LinuxDMABuf.hsc: -------------------------------------------------------------------------------- 1 | module Graphics.Wayland.WlRoots.LinuxDMABuf 2 | ( LinuxDMABuf (..) 3 | , createDMABuf 4 | , destroyDMABuf 5 | ) 6 | where 7 | 8 | import Foreign.Ptr (Ptr) 9 | import Foreign.C.Error (throwErrnoIfNull) 10 | 11 | import Graphics.Wayland.Server (DisplayServer(..)) 12 | 13 | import Graphics.Wayland.WlRoots.Render (Renderer) 14 | import Graphics.Wayland.WlRoots.Backend (Backend, backendGetRenderer) 15 | 16 | newtype LinuxDMABuf = LinuxDMABuf (Ptr LinuxDMABuf) 17 | 18 | foreign import ccall unsafe "wlr_linux_dmabuf_v1_create" c_create :: Ptr DisplayServer -> Ptr Renderer -> IO (Ptr LinuxDMABuf) 19 | 20 | createDMABuf :: DisplayServer -> Ptr Backend -> IO LinuxDMABuf 21 | createDMABuf (DisplayServer dsp) backend = 22 | LinuxDMABuf <$> throwErrnoIfNull "creatELinuxDMABuf" (c_create dsp =<< backendGetRenderer backend) 23 | 24 | foreign import ccall "wlr_linux_dmabuf_v1_destroy" c_destroy :: Ptr LinuxDMABuf -> IO () 25 | 26 | destroyDMABuf :: LinuxDMABuf -> IO () 27 | destroyDMABuf (LinuxDMABuf ptr) = c_destroy ptr 28 | -------------------------------------------------------------------------------- /src/Graphics/Wayland/WlRoots/Output.hsc: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE EmptyDataDecls #-} 2 | {-# LANGUAGE TupleSections #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | {-# LANGUAGE NumDecimals #-} 5 | module Graphics.Wayland.WlRoots.Output 6 | ( WlrOutput 7 | , outputEnable 8 | , outputDisable 9 | , isOutputEnabled 10 | , makeOutputCurrent 11 | , swapOutputBuffers 12 | , getOutputPosition 13 | 14 | , effectiveResolution 15 | , destroyOutput 16 | 17 | , OutputMode(..) 18 | , setOutputMode 19 | 20 | , hasModes 21 | , getModes 22 | , getMode 23 | , getWidth 24 | , getHeight 25 | , getTransMatrix 26 | 27 | , OutputSignals(..) 28 | , getOutputSignals 29 | , getDataPtr 30 | 31 | , transformOutput 32 | , getOutputTransform 33 | 34 | , getEffectiveBox 35 | , getOutputBox 36 | , getOutputName 37 | , getOutputScale 38 | , setOutputScale 39 | 40 | , getMake 41 | , getModel 42 | , getSerial 43 | 44 | , getOutputNeedsSwap 45 | , setOutputNeedsSwap 46 | 47 | , destroyOutputGlobal 48 | , createOutputGlobal 49 | 50 | , scheduleOutputFrame 51 | , outputTransformedResolution 52 | , invertOutputTransform 53 | , composeOutputTransform 54 | , getOutputDamage 55 | , outputFromResource 56 | , outputResourceForClient 57 | , outputGetBackend 58 | ) 59 | where 60 | 61 | #define WLR_USE_UNSTABLE 62 | #include 63 | #include 64 | 65 | import Control.Monad (filterM) 66 | import Data.ByteString.Unsafe (unsafePackCString) 67 | import Data.Int (Int32) 68 | --import Data.Maybe (fromMaybe) 69 | import Data.Text (Text) 70 | import Data.Word (Word32, Word8, Word64) 71 | import Foreign.C.Error (throwErrnoIf_) 72 | import Foreign.C.Types (CInt(..), CLong (..)) 73 | import Foreign.Marshal.Alloc (alloca, allocaBytes) 74 | import Foreign.Ptr (Ptr, plusPtr, nullPtr) 75 | import Foreign.Storable (Storable(..)) 76 | 77 | import Graphics.Pixman 78 | 79 | import Graphics.Wayland.Resource (WlResource, resourceFromLink, resourceGetClient) 80 | import Graphics.Wayland.Server (Client (..)) 81 | import Graphics.Wayland.WlRoots.Render.Matrix (Matrix(..)) 82 | import Graphics.Wayland.WlRoots.Box (WlrBox(..), Point (..)) 83 | import Graphics.Wayland.Signal (WlSignal) 84 | import Graphics.Wayland.Server (OutputTransform(..)) 85 | import Graphics.Wayland.List (getListFromHead, isListEmpty, getListElems) 86 | 87 | import qualified Data.Text as T 88 | import qualified Data.Text.Encoding as E 89 | 90 | data WlrOutput 91 | 92 | getOutputName :: Ptr WlrOutput -> IO Text 93 | getOutputName = fmap E.decodeUtf8 . unsafePackCString . #{ptr struct wlr_output, name} 94 | 95 | makeMaybe :: Text -> Maybe Text 96 | makeMaybe txt = if T.null txt then Nothing else Just txt 97 | 98 | getMake :: Ptr WlrOutput -> IO (Maybe Text) 99 | getMake = fmap (makeMaybe . E.decodeUtf8) . unsafePackCString . #{ptr struct wlr_output, make} 100 | 101 | getModel :: Ptr WlrOutput -> IO (Maybe Text) 102 | getModel = fmap (makeMaybe . E.decodeUtf8) . unsafePackCString . #{ptr struct wlr_output, model} 103 | 104 | getSerial :: Ptr WlrOutput -> IO (Maybe Text) 105 | getSerial = fmap (makeMaybe . E.decodeUtf8) . unsafePackCString . #{ptr struct wlr_output, serial} 106 | 107 | getOutputPosition :: Ptr WlrOutput -> IO Point 108 | getOutputPosition ptr = do 109 | x :: Int32 <- #{peek struct wlr_output, lx} ptr 110 | y :: Int32 <- #{peek struct wlr_output, ly} ptr 111 | pure $ Point (fromIntegral x) (fromIntegral y) 112 | 113 | foreign import ccall unsafe "wlr_output_enable" c_output_enable :: Ptr WlrOutput -> Bool -> IO () 114 | 115 | outputEnable :: Ptr WlrOutput -> IO () 116 | outputEnable = flip c_output_enable True 117 | 118 | outputDisable :: Ptr WlrOutput -> IO () 119 | outputDisable = flip c_output_enable False 120 | 121 | isOutputEnabled :: Ptr WlrOutput -> IO Bool 122 | isOutputEnabled = fmap (/= (0 :: Word8)) . #{peek struct wlr_output, enabled} 123 | 124 | foreign import ccall unsafe "wlr_output_make_current" c_make_current :: Ptr WlrOutput -> Ptr CInt -> IO Word8 125 | makeOutputCurrent :: Ptr WlrOutput -> IO (Maybe Int) 126 | makeOutputCurrent out = alloca $ \ptr -> do 127 | ret <- c_make_current out ptr 128 | if ret == 0 129 | then pure Nothing 130 | else Just . fromIntegral <$> peek ptr 131 | 132 | 133 | foreign import ccall unsafe "wlr_output_swap_buffers" c_swap_buffers :: Ptr WlrOutput -> Ptr () -> Ptr PixmanRegion32 -> IO Word8 134 | swapOutputBuffers :: Ptr WlrOutput -> Maybe Integer -> Maybe (Ptr PixmanRegion32) -> IO Bool 135 | swapOutputBuffers out time _ {-damage-} = 136 | let withTime = case time of 137 | Nothing -> ($ nullPtr) 138 | Just t -> \act -> allocaBytes #{size struct timespec} $ \ptr -> do 139 | let secs :: Word64 = fromIntegral (t `div` 1e9) 140 | let nsecs :: CLong = fromIntegral (t `mod` 1e9) 141 | #{poke struct timespec, tv_sec} ptr secs 142 | #{poke struct timespec, tv_nsec} ptr nsecs 143 | act ptr 144 | in (/= 0) <$> withTime (\t -> c_swap_buffers out t {-(fromMaybe nullPtr damage)-} nullPtr) 145 | 146 | 147 | foreign import ccall unsafe "wlr_output_destroy" c_output_destroy :: Ptr WlrOutput -> IO () 148 | 149 | destroyOutput :: Ptr WlrOutput -> IO () 150 | destroyOutput = c_output_destroy 151 | 152 | 153 | foreign import ccall unsafe "wlr_output_effective_resolution" c_effective_resolution :: Ptr WlrOutput -> Ptr CInt -> Ptr CInt -> IO () 154 | 155 | effectiveResolution :: Ptr WlrOutput -> IO (Int, Int) 156 | effectiveResolution output = alloca $ \width -> alloca $ \height -> do 157 | c_effective_resolution output width height 158 | width_val <- peek width 159 | height_val <- peek height 160 | pure (fromIntegral width_val, fromIntegral height_val) 161 | 162 | getEffectiveBox :: Ptr WlrOutput -> IO WlrBox 163 | getEffectiveBox ptr = do 164 | phys <- getOutputBox ptr 165 | (width, height) <- effectiveResolution ptr 166 | pure phys {boxWidth = width, boxHeight = height} 167 | 168 | foreign import ccall "wlr_output_set_transform" c_output_transform :: Ptr WlrOutput -> CInt -> IO () 169 | 170 | transformOutput :: Ptr WlrOutput -> OutputTransform -> IO () 171 | transformOutput ptr (OutputTransform x) = 172 | c_output_transform ptr (fromIntegral x) 173 | 174 | getOutputTransform :: Ptr WlrOutput -> IO OutputTransform 175 | getOutputTransform ptr = do 176 | val :: CInt <- #{peek struct wlr_output, transform} ptr 177 | pure $ OutputTransform (fromIntegral val) 178 | 179 | data OutputMode = OutputMode 180 | { modeFlags :: Word32 181 | , modeWidth :: Word32 182 | , modeHeight :: Word32 183 | , modeRefresh :: Word32 184 | } 185 | deriving (Eq, Show) 186 | 187 | instance Storable OutputMode where 188 | alignment _ = #{alignment struct wlr_output_mode} 189 | sizeOf _ = #{size struct wlr_output_mode} 190 | peek ptr = OutputMode 191 | <$> #{peek struct wlr_output_mode, flags} ptr 192 | <*> #{peek struct wlr_output_mode, width} ptr 193 | <*> #{peek struct wlr_output_mode, height} ptr 194 | <*> #{peek struct wlr_output_mode, refresh} ptr 195 | poke = error "We do not poke output modes" 196 | 197 | foreign import ccall "wlr_output_set_mode" c_set_mode :: Ptr WlrOutput -> Ptr OutputMode -> IO Bool 198 | 199 | setOutputMode :: Ptr OutputMode -> Ptr WlrOutput -> IO () 200 | setOutputMode mptr ptr = 201 | throwErrnoIf_ not "setOutputMode" $ c_set_mode ptr mptr 202 | 203 | 204 | getWidth :: Ptr WlrOutput -> IO Int32 205 | getWidth = #{peek struct wlr_output, width} 206 | 207 | getHeight :: Ptr WlrOutput -> IO Int32 208 | getHeight = #{peek struct wlr_output, height} 209 | 210 | hasModes :: Ptr WlrOutput -> IO Bool 211 | hasModes = fmap not . isListEmpty . #{ptr struct wlr_output, modes} 212 | 213 | getModes :: Ptr WlrOutput -> IO [Ptr OutputMode] 214 | getModes ptr = do 215 | let listptr = #{ptr struct wlr_output, modes} ptr 216 | getListFromHead listptr #{offset struct wlr_output_mode, link} 217 | 218 | getMode :: Ptr WlrOutput -> IO (Maybe (Ptr OutputMode)) 219 | getMode ptr = do 220 | ret <- #{peek struct wlr_output, current_mode} ptr 221 | if ret == nullPtr 222 | then pure Nothing 223 | else pure $ Just ret 224 | 225 | getTransMatrix :: Ptr WlrOutput -> Matrix 226 | getTransMatrix = 227 | Matrix . #{ptr struct wlr_output, transform_matrix} 228 | 229 | data OutputSignals = OutputSignals 230 | { outSignalFrame :: Ptr (WlSignal WlrOutput) 231 | , outSignalMode :: Ptr (WlSignal WlrOutput) 232 | , outSignalScale :: Ptr (WlSignal WlrOutput) 233 | , outSignalTransform :: Ptr (WlSignal WlrOutput) 234 | , outSignalDestroy :: Ptr (WlSignal WlrOutput) 235 | , outSignalNeedsSwap :: Ptr (WlSignal WlrOutput) 236 | } 237 | 238 | getOutputSignals :: Ptr WlrOutput -> OutputSignals 239 | getOutputSignals ptr = OutputSignals 240 | { outSignalFrame = #{ptr struct wlr_output, events.frame} ptr 241 | , outSignalMode = #{ptr struct wlr_output, events.mode} ptr 242 | , outSignalScale = #{ptr struct wlr_output, events.scale} ptr 243 | , outSignalTransform = #{ptr struct wlr_output, events.transform} ptr 244 | , outSignalDestroy = #{ptr struct wlr_output, events.destroy} ptr 245 | , outSignalNeedsSwap = #{ptr struct wlr_output, events.needs_swap} ptr 246 | } 247 | 248 | getDataPtr :: Ptr WlrOutput -> Ptr (Ptr a) 249 | getDataPtr = #{ptr struct wlr_output, data} 250 | 251 | 252 | getOutputBox :: Ptr WlrOutput -> IO WlrBox 253 | getOutputBox ptr = do 254 | x :: Word32 <- #{peek struct wlr_output, lx} ptr 255 | y :: Word32 <- #{peek struct wlr_output, ly} ptr 256 | width :: Word32 <- #{peek struct wlr_output, width} ptr 257 | height :: Word32 <- #{peek struct wlr_output, height} ptr 258 | pure $ WlrBox (fromIntegral x) (fromIntegral y) (fromIntegral width) (fromIntegral height) 259 | 260 | getOutputScale :: Ptr WlrOutput -> IO Float 261 | getOutputScale = #{peek struct wlr_output, scale} 262 | 263 | foreign import ccall "wlr_output_set_scale" c_set_scale :: Ptr WlrOutput -> Float -> IO () 264 | 265 | setOutputScale :: Ptr WlrOutput -> Float -> IO () 266 | setOutputScale = c_set_scale 267 | 268 | getOutputNeedsSwap :: Ptr WlrOutput -> IO Bool 269 | getOutputNeedsSwap = fmap (/= (0 :: Word8)) . #{peek struct wlr_output, needs_swap} 270 | 271 | setOutputNeedsSwap :: Ptr WlrOutput -> Bool -> IO () 272 | setOutputNeedsSwap ptr val = 273 | #{poke struct wlr_output, needs_swap} ptr (if val then 1 else 0 :: Word8) 274 | 275 | foreign import ccall "wlr_output_create_global" c_create_global :: Ptr WlrOutput -> IO () 276 | 277 | createOutputGlobal :: Ptr WlrOutput -> IO () 278 | createOutputGlobal = c_create_global 279 | 280 | foreign import ccall "wlr_output_destroy_global" c_destroy_global :: Ptr WlrOutput -> IO () 281 | 282 | destroyOutputGlobal :: Ptr WlrOutput -> IO () 283 | destroyOutputGlobal = c_destroy_global 284 | 285 | foreign import ccall unsafe "wlr_output_transformed_resolution" c_transformed_resolution :: Ptr WlrOutput -> Ptr CInt -> Ptr CInt -> IO () 286 | 287 | outputTransformedResolution :: Ptr WlrOutput -> IO Point 288 | outputTransformedResolution ptr = alloca $ \xptr -> alloca $ \yptr -> do 289 | c_transformed_resolution ptr xptr yptr 290 | x <- peek xptr 291 | y <- peek yptr 292 | pure $ Point (fromIntegral x) (fromIntegral y) 293 | 294 | foreign import ccall unsafe "wlr_output_schedule_frame" c_schedule_frame :: Ptr WlrOutput -> IO () 295 | 296 | scheduleOutputFrame :: Ptr WlrOutput -> IO () 297 | scheduleOutputFrame = c_schedule_frame 298 | 299 | foreign import ccall unsafe "wlr_output_transform_invert" c_transform_invert :: CInt -> CInt 300 | 301 | invertOutputTransform :: OutputTransform -> OutputTransform 302 | invertOutputTransform (OutputTransform val) = OutputTransform . fromIntegral $ c_transform_invert (fromIntegral val) 303 | 304 | foreign import ccall unsafe "wlr_output_transform_compose" c_transform_compose :: CInt -> CInt -> CInt 305 | 306 | composeOutputTransform :: OutputTransform -> OutputTransform -> OutputTransform 307 | composeOutputTransform (OutputTransform l) (OutputTransform r) = 308 | OutputTransform . fromIntegral $ c_transform_compose (fromIntegral l) (fromIntegral r) 309 | 310 | getOutputDamage :: Ptr WlrOutput -> PixmanRegion32 311 | getOutputDamage = PixmanRegion32 . #{ptr struct wlr_output, damage} 312 | 313 | foreign import ccall unsafe "wlr_output_from_resource" c_from_resource :: Ptr WlResource -> IO (Ptr WlrOutput) 314 | 315 | outputFromResource :: Ptr WlResource -> IO (Ptr WlrOutput) 316 | outputFromResource = c_from_resource 317 | 318 | outputResourceForClient :: Client -> Ptr WlrOutput -> IO (Ptr WlResource) 319 | outputResourceForClient target output = do 320 | elems <- getListElems $ #{ptr struct wlr_output, resources} output 321 | ret <- flip filterM elems $ \link -> do 322 | client <- resourceGetClient $ resourceFromLink link 323 | pure (client == target) 324 | pure . resourceFromLink $ head ret 325 | 326 | outputGetBackend :: Ptr WlrOutput -> IO (Ptr a) 327 | outputGetBackend = #{peek struct wlr_output, backend} 328 | -------------------------------------------------------------------------------- /src/Graphics/Wayland/WlRoots/OutputLayout.hsc: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | module Graphics.Wayland.WlRoots.OutputLayout 3 | ( WlrOutputLayout 4 | , createOutputLayout 5 | , destroyOutputLayout 6 | 7 | , WlrOutputLayoutOutput 8 | , layoutOuputGetPosition 9 | , layoutGetOutput 10 | , layoutAtPos 11 | 12 | , layoutOutputGetOutput 13 | , layoutGetOutputs 14 | 15 | , addOutput 16 | , moveOutput 17 | , removeOutput 18 | 19 | , outputContainsPoint 20 | , outputIntersects 21 | 22 | , closestPoint 23 | , addOutputAuto 24 | , getOutputLayoutExtends 25 | , getOutputLayoutBox 26 | ) 27 | where 28 | 29 | #define WLR_USE_UNSTABLE 30 | #include 31 | 32 | import Foreign.Ptr (Ptr, nullPtr, plusPtr) 33 | import Foreign.C.Error (throwErrnoIfNull) 34 | import Foreign.C.Types (CInt(..)) 35 | import Foreign.Marshal.Alloc (alloca) 36 | import Foreign.Marshal.Utils (with) 37 | import Foreign.Storable (Storable(peek, peekByteOff)) 38 | import Data.Composition ((.:)) 39 | 40 | import Graphics.Wayland.WlRoots.Output (WlrOutput) 41 | import Graphics.Wayland.WlRoots.Box (WlrBox, Point(..)) 42 | import Graphics.Wayland.List (getListFromHead) 43 | 44 | data WlrOutputLayout 45 | 46 | foreign import ccall "wlr_output_layout_create" c_layout_create :: IO (Ptr WlrOutputLayout) 47 | 48 | createOutputLayout :: IO (Ptr WlrOutputLayout) 49 | createOutputLayout = throwErrnoIfNull "createOutputLayout" c_layout_create 50 | 51 | 52 | foreign import ccall "wlr_output_layout_destroy" c_layout_destroy :: Ptr WlrOutputLayout -> IO () 53 | 54 | destroyOutputLayout :: Ptr WlrOutputLayout -> IO () 55 | destroyOutputLayout = c_layout_destroy 56 | 57 | 58 | data WlrOutputLayoutOutput 59 | 60 | layoutOuputGetPosition :: Ptr WlrOutputLayoutOutput -> IO Point 61 | layoutOuputGetPosition ptr = do 62 | x :: CInt <- #{peek struct wlr_output_layout_output, x} ptr 63 | y :: CInt <- #{peek struct wlr_output_layout_output, y} ptr 64 | pure $ Point (fromIntegral x) (fromIntegral y) 65 | 66 | foreign import ccall "wlr_output_layout_get" c_layout_get :: Ptr WlrOutputLayout -> Ptr WlrOutput -> IO (Ptr WlrOutputLayoutOutput) 67 | 68 | layoutGetOutput :: Ptr WlrOutputLayout -> Ptr WlrOutput -> IO (Ptr WlrOutputLayoutOutput) 69 | layoutGetOutput = throwErrnoIfNull "layoutGetOutput" .: c_layout_get 70 | 71 | layoutOutputGetOutput :: Ptr WlrOutputLayoutOutput -> IO (Ptr WlrOutput) 72 | layoutOutputGetOutput = #{peek struct wlr_output_layout_output, output} 73 | 74 | layoutGetOutputs :: Ptr WlrOutputLayout -> IO [Ptr WlrOutputLayoutOutput] 75 | layoutGetOutputs layout = 76 | getListFromHead (#{ptr struct wlr_output_layout, outputs} layout) #{offset struct wlr_output_layout_output, link} 77 | 78 | 79 | foreign import ccall "wlr_output_layout_output_at" c_layout_at :: Ptr WlrOutputLayout -> Double -> Double -> IO (Ptr WlrOutput) 80 | 81 | layoutAtPos :: Ptr WlrOutputLayout -> Double -> Double -> IO (Maybe (Ptr WlrOutput)) 82 | layoutAtPos layout x y = do 83 | ret <- c_layout_at layout x y 84 | pure $ if ret == nullPtr 85 | then Nothing 86 | else Just ret 87 | 88 | 89 | foreign import ccall "wlr_output_layout_add" c_output_add :: Ptr WlrOutputLayout -> Ptr WlrOutput -> CInt -> CInt -> IO () 90 | 91 | addOutput :: Ptr WlrOutputLayout -> Ptr WlrOutput -> Int -> Int -> IO () 92 | addOutput layout output x y = 93 | c_output_add layout output (fromIntegral x) (fromIntegral y) 94 | 95 | 96 | foreign import ccall "wlr_output_layout_move" c_output_move :: Ptr WlrOutputLayout -> Ptr WlrOutput -> CInt -> CInt -> IO () 97 | 98 | moveOutput :: Ptr WlrOutputLayout -> Ptr WlrOutput -> Int -> Int -> IO () 99 | moveOutput layout output x y = 100 | c_output_move layout output (fromIntegral x) (fromIntegral y) 101 | 102 | 103 | foreign import ccall "wlr_output_layout_remove" c_output_remove :: Ptr WlrOutputLayout -> Ptr WlrOutput -> IO () 104 | 105 | removeOutput :: Ptr WlrOutputLayout -> Ptr WlrOutput -> IO () 106 | removeOutput layout output = 107 | c_output_remove layout output 108 | 109 | foreign import ccall unsafe "wlr_output_layout_get_box" c_get_box :: Ptr WlrOutputLayout -> Ptr WlrOutput -> IO (Ptr WlrBox) 110 | 111 | getOutputLayoutBox :: Ptr WlrOutputLayout -> Ptr WlrOutput -> IO WlrBox 112 | getOutputLayoutBox layout out = peek =<< c_get_box layout out 113 | 114 | getOutputLayoutExtends :: Ptr WlrOutputLayout -> IO WlrBox 115 | getOutputLayoutExtends layout = getOutputLayoutBox layout nullPtr 116 | 117 | foreign import ccall "wlr_output_layout_contains_point" c_contains_point :: Ptr WlrOutputLayout -> Ptr WlrOutput -> CInt -> CInt -> IO Bool 118 | 119 | outputContainsPoint :: Ptr WlrOutputLayout -> Ptr WlrOutput -> Int -> Int -> IO Bool 120 | outputContainsPoint layout output x y = c_contains_point layout output (fromIntegral x) (fromIntegral y) 121 | 122 | 123 | foreign import ccall "wlr_output_layout_intersects" c_intersects :: Ptr WlrOutputLayout -> Ptr WlrOutput -> Ptr WlrBox -> IO Bool 124 | 125 | outputIntersects :: Ptr WlrOutputLayout -> Ptr WlrOutput -> WlrBox -> IO Bool 126 | outputIntersects layout output box = with box $ c_intersects layout output 127 | 128 | 129 | foreign import ccall "wlr_output_layout_closest_point" c_closest_point :: Ptr WlrOutputLayout -> Ptr WlrOutput -> Double -> Double -> Ptr Double -> Ptr Double -> IO () 130 | 131 | closestPoint :: Ptr WlrOutputLayout -> Maybe (Ptr WlrOutput) -> Double -> Double -> IO (Double, Double) 132 | closestPoint layout Nothing x y = closestPoint layout (Just nullPtr) x y 133 | closestPoint layout (Just output) x y = alloca $ \xptr -> alloca $ \yptr -> do 134 | c_closest_point layout output x y xptr yptr 135 | xret <- peek xptr 136 | yret <- peek yptr 137 | pure (xret, yret) 138 | 139 | -- TODO: Box 140 | 141 | foreign import ccall "wlr_output_layout_add_auto" c_add_auto :: Ptr WlrOutputLayout -> Ptr WlrOutput -> IO () 142 | 143 | addOutputAuto :: Ptr WlrOutputLayout -> Ptr WlrOutput -> IO () 144 | addOutputAuto = c_add_auto 145 | -------------------------------------------------------------------------------- /src/Graphics/Wayland/WlRoots/PrimarySelection.hsc: -------------------------------------------------------------------------------- 1 | module Graphics.Wayland.WlRoots.PrimarySelection 2 | ( PrimarySelectionManager (..) 3 | , createPrimaryDeviceManager 4 | , destroyPrimaryDeviceManager 5 | , getPrimaryGlobal 6 | ) 7 | where 8 | 9 | #define WLR_USE_UNSTABLE 10 | #include 11 | 12 | import Foreign.C.Error (throwErrnoIfNull) 13 | import Foreign.Ptr (Ptr) 14 | import Foreign.Storable (Storable (..)) 15 | 16 | import Graphics.Wayland.Server (DisplayServer (..)) 17 | import Graphics.Wayland.Global (WlGlobal) 18 | 19 | newtype PrimarySelectionManager = PrimarySelectionManager { unPSM :: Ptr PrimarySelectionManager} 20 | 21 | foreign import ccall unsafe "wlr_primary_selection_device_manager_create" c_create :: Ptr DisplayServer -> IO (Ptr PrimarySelectionManager) 22 | 23 | createPrimaryDeviceManager :: DisplayServer -> IO PrimarySelectionManager 24 | createPrimaryDeviceManager (DisplayServer ptr) = fmap PrimarySelectionManager . 25 | throwErrnoIfNull "createPrimaryDeviceManager" $ c_create ptr 26 | 27 | foreign import ccall safe "wlr_primary_selection_device_manager_destroy" c_destroy :: Ptr PrimarySelectionManager -> IO () 28 | 29 | destroyPrimaryDeviceManager :: PrimarySelectionManager -> IO () 30 | destroyPrimaryDeviceManager = c_destroy . unPSM 31 | 32 | getPrimaryGlobal :: PrimarySelectionManager -> IO (Ptr WlGlobal) 33 | getPrimaryGlobal = #{peek struct wlr_primary_selection_device_manager, global} . unPSM 34 | -------------------------------------------------------------------------------- /src/Graphics/Wayland/WlRoots/Render.hsc: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE EmptyDataDecls #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | module Graphics.Wayland.WlRoots.Render 4 | ( Renderer 5 | , Texture 6 | 7 | , renderWithMatrix 8 | , renderWithMatrixA 9 | , rendererDestroy 10 | 11 | , rendererBegin 12 | , rendererEnd 13 | 14 | , doRender 15 | , getTextureSize 16 | 17 | , renderColoredQuad 18 | 19 | , rendererScissor 20 | , rendererClear 21 | 22 | , initWlDisplay 23 | ) 24 | where 25 | 26 | #define WLR_USE_UNSTABLE 27 | #include 28 | 29 | import Control.Exception (bracket_) 30 | import Foreign.C.Error ({-throwErrnoIfNull, -}throwErrnoIf_) 31 | import Foreign.C.Types (CFloat(..), CInt(..)) 32 | import Foreign.Marshal.Alloc (alloca) 33 | import Foreign.Marshal.Utils (with) 34 | import Foreign.Ptr (Ptr, nullPtr) 35 | import Foreign.Storable (Storable(..)) 36 | 37 | import Graphics.Wayland.Server (DisplayServer (..)) 38 | 39 | import Graphics.Wayland.WlRoots.Output (WlrOutput, getWidth, getHeight) 40 | import Graphics.Wayland.WlRoots.Render.Color (Color) 41 | import Graphics.Wayland.WlRoots.Render.Matrix (Matrix(..)) 42 | import Graphics.Wayland.WlRoots.Box (WlrBox) 43 | 44 | data Renderer 45 | data Texture 46 | 47 | foreign import ccall unsafe "wlr_renderer_begin" c_renderer_begin :: Ptr Renderer -> CInt -> CInt -> IO () 48 | 49 | rendererBegin :: Ptr Renderer -> CInt -> CInt -> IO () 50 | rendererBegin = c_renderer_begin 51 | 52 | 53 | foreign import ccall unsafe "wlr_renderer_end" c_renderer_end :: Ptr Renderer -> IO () 54 | 55 | rendererEnd :: Ptr Renderer -> IO () 56 | rendererEnd = c_renderer_end 57 | 58 | 59 | doRender :: Ptr Renderer -> Ptr WlrOutput -> IO a -> IO a 60 | doRender renderer output act = do 61 | width <- getWidth output 62 | height <- getHeight output 63 | bracket_ 64 | (rendererBegin renderer (fromIntegral width) (fromIntegral height)) 65 | (rendererEnd renderer) 66 | act 67 | 68 | foreign import ccall unsafe "wlr_render_texture_with_matrix" c_render_with_matrix :: Ptr Renderer -> Ptr Texture -> Ptr CFloat -> CFloat -> IO Bool 69 | 70 | renderWithMatrix :: Ptr Renderer -> Ptr Texture -> Matrix -> IO () 71 | renderWithMatrix r t (Matrix m) = throwErrnoIf_ not "renderWithMatrix" $ c_render_with_matrix r t m 1.0 72 | 73 | renderWithMatrixA :: Ptr Renderer -> Ptr Texture -> Matrix -> CFloat -> IO () 74 | renderWithMatrixA r t (Matrix m) a = throwErrnoIf_ not "renderWithMatrixA" $ c_render_with_matrix r t m a 75 | 76 | 77 | foreign import ccall unsafe "wlr_renderer_destroy" c_renderer_destroy :: Ptr Renderer -> IO () 78 | 79 | rendererDestroy :: Ptr Renderer -> IO () 80 | rendererDestroy = c_renderer_destroy 81 | 82 | foreign import ccall unsafe "wlr_render_quad_with_matrix" c_colored_quad :: Ptr Renderer -> Ptr Color -> Ptr CFloat -> IO () 83 | 84 | renderColoredQuad :: Ptr Renderer -> Color -> Matrix -> IO () 85 | renderColoredQuad rend col (Matrix m) = with col $ \cptr -> 86 | c_colored_quad rend cptr m 87 | 88 | foreign import ccall unsafe "wlr_renderer_clear" c_clear :: Ptr Renderer -> Ptr Color -> IO () 89 | 90 | rendererClear :: Ptr Renderer -> Color -> IO () 91 | rendererClear rend col = with col $ c_clear rend 92 | 93 | foreign import ccall unsafe "wlr_texture_get_size" c_get_size :: Ptr Texture -> Ptr CInt -> Ptr CInt -> IO () 94 | 95 | getTextureSize :: Ptr Texture -> IO (Int, Int) 96 | getTextureSize ptr = do 97 | (width, height) <- alloca $ \widthPtr -> alloca $ \heightPtr -> c_get_size ptr widthPtr heightPtr >> peekTextureSize widthPtr heightPtr 98 | pure (fromIntegral width, fromIntegral height) 99 | where peekTextureSize :: Ptr CInt -> Ptr CInt -> IO (CInt, CInt) 100 | peekTextureSize widthPtr heightPtr = do 101 | width <- peek widthPtr 102 | height <- peek heightPtr 103 | pure (width, height) 104 | 105 | foreign import ccall unsafe "wlr_renderer_scissor" c_scissor :: Ptr Renderer -> Ptr WlrBox -> IO () 106 | 107 | rendererScissor :: Ptr Renderer -> Maybe WlrBox -> IO () 108 | rendererScissor rend (Just box) = with box $ c_scissor rend 109 | rendererScissor rend Nothing = c_scissor rend nullPtr 110 | 111 | 112 | foreign import ccall unsafe "wlr_renderer_init_wl_display" c_init_display :: Ptr Renderer -> Ptr DisplayServer -> IO () 113 | 114 | initWlDisplay :: DisplayServer -> Ptr Renderer -> IO () 115 | initWlDisplay (DisplayServer dsp) rend = c_init_display rend dsp 116 | -------------------------------------------------------------------------------- /src/Graphics/Wayland/WlRoots/Render/Color.hs: -------------------------------------------------------------------------------- 1 | module Graphics.Wayland.WlRoots.Render.Color 2 | ( Color (..) 3 | , colorWhite 4 | , colorBlack 5 | , darkenBy 6 | ) 7 | where 8 | 9 | import Foreign.Ptr (castPtr) 10 | import Foreign.Storable (Storable(..)) 11 | 12 | data Color = Color 13 | { colorR :: Float 14 | , colorG :: Float 15 | , colorB :: Float 16 | , colorA :: Float 17 | } deriving (Show) 18 | 19 | darkenBy :: Float -> Color -> Color 20 | darkenBy d (Color r g b a) = 21 | Color (r * d) (g * d) (b * d) a 22 | 23 | instance Storable Color where 24 | sizeOf _ = 4 * sizeOf (undefined :: Float) 25 | alignment _ = alignment (undefined :: Int) 26 | peek ptr = Color 27 | <$> peekElemOff (castPtr ptr) 0 28 | <*> peekElemOff (castPtr ptr) 1 29 | <*> peekElemOff (castPtr ptr) 2 30 | <*> peekElemOff (castPtr ptr) 3 31 | poke ptr c = do 32 | pokeElemOff (castPtr ptr) 0 $ colorR c 33 | pokeElemOff (castPtr ptr) 1 $ colorG c 34 | pokeElemOff (castPtr ptr) 2 $ colorB c 35 | pokeElemOff (castPtr ptr) 3 $ colorA c 36 | 37 | colorWhite :: Color 38 | colorWhite = Color 1 1 1 1 39 | 40 | colorBlack :: Color 41 | colorBlack = Color 0 0 0 1 42 | -------------------------------------------------------------------------------- /src/Graphics/Wayland/WlRoots/Render/Gles2.hs: -------------------------------------------------------------------------------- 1 | module Graphics.Wayland.WlRoots.Render.Gles2 2 | ( rendererCreate 3 | ) 4 | where 5 | 6 | import Foreign.C.Error (throwErrnoIfNull) 7 | import Foreign.Ptr (Ptr) 8 | import Graphics.Wayland.WlRoots.Render (Renderer) 9 | import Graphics.Wayland.WlRoots.Backend (Backend) 10 | 11 | foreign import ccall unsafe "wlr_gles2_renderer_create" c_renderer_create :: Ptr Backend -> IO (Ptr Renderer) 12 | 13 | rendererCreate :: Ptr Backend -> IO (Ptr Renderer) 14 | rendererCreate = throwErrnoIfNull "rendererCreate" . c_renderer_create 15 | -------------------------------------------------------------------------------- /src/Graphics/Wayland/WlRoots/Render/Matrix.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | module Graphics.Wayland.WlRoots.Render.Matrix 3 | ( Matrix(..) 4 | -- | This entir emodule should probably replaced by types reimplemented in 5 | -- Haskell to get out of IO for simple matrix calculations 6 | 7 | , withMatrix 8 | , withIdentity 9 | 10 | , printMatrix 11 | 12 | -- | This is the low level interface exported by wlroots. 13 | , matrixIdentity 14 | , matrixTranslate 15 | , matrixScale 16 | , matrixRotate 17 | , matrixMul 18 | 19 | , matrixProjectBox 20 | ) 21 | where 22 | 23 | import System.IO 24 | import Foreign.Storable (Storable(..)) 25 | import Foreign.Ptr (Ptr) 26 | import Foreign.C.Types (CFloat(..), CInt (..)) 27 | import Foreign.Marshal.Alloc (allocaBytes) 28 | import Foreign.Marshal.Utils (with) 29 | 30 | import Graphics.Wayland.Server (OutputTransform(..)) 31 | import Graphics.Wayland.WlRoots.Box (WlrBox) 32 | 33 | -- | This has to be a float[16]. The 'withMatrix' makes sure it is. 34 | newtype Matrix = Matrix { unMatrix :: (Ptr CFloat) } 35 | 36 | -- | Do something with a matrix. This needs to be IO for at least as long as we 37 | -- keep the matrix type/operations from wlroots 38 | withMatrix :: (Matrix -> IO a) -> IO a 39 | withMatrix act = allocaBytes (9 * 4) $ act . Matrix 40 | 41 | -- | Same as 'withMatrix' but make sure the matrix is the identity matrix. 42 | withIdentity :: (Matrix -> IO a) -> IO a 43 | withIdentity act = withMatrix $ \m -> do 44 | matrixIdentity m 45 | act m 46 | 47 | 48 | foreign import ccall unsafe "wlr_matrix_identity" c_matrix_identity :: Ptr CFloat -> IO () 49 | 50 | matrixIdentity :: Matrix -> IO () 51 | matrixIdentity = c_matrix_identity . unMatrix 52 | 53 | 54 | foreign import ccall unsafe "wlr_matrix_translate" c_matrix_translate :: Ptr CFloat -> CFloat -> CFloat -> IO () 55 | 56 | matrixTranslate :: Matrix -> Float -> Float -> IO () 57 | matrixTranslate (Matrix p) x y = c_matrix_translate p (CFloat x) (CFloat y) 58 | 59 | 60 | foreign import ccall unsafe "wlr_matrix_scale" c_matrix_scale :: Ptr CFloat -> CFloat -> CFloat -> IO () 61 | 62 | matrixScale :: Matrix -> Float -> Float -> IO () 63 | matrixScale (Matrix p) x y = c_matrix_scale p (CFloat x) (CFloat y) 64 | 65 | 66 | foreign import ccall unsafe "wlr_matrix_rotate" c_matrix_rotate :: Ptr CFloat -> CFloat -> IO () 67 | 68 | matrixRotate :: Matrix -> Float -> IO () 69 | matrixRotate (Matrix p) r = c_matrix_rotate p (CFloat r) 70 | 71 | 72 | foreign import ccall unsafe "wlr_matrix_multiply" c_matrix_mul :: Ptr CFloat -> Ptr CFloat -> Ptr CFloat -> IO () 73 | 74 | matrixMul :: Matrix -> Matrix -> Matrix -> IO () 75 | matrixMul (Matrix x) (Matrix y) (Matrix o) = c_matrix_mul x y o 76 | 77 | 78 | foreign import ccall unsafe "wlr_matrix_project_box" c_project_box :: Ptr CFloat -> Ptr WlrBox -> CInt -> CFloat -> Ptr CFloat -> IO () 79 | 80 | matrixProjectBox :: Matrix -> WlrBox -> OutputTransform -> Float -> Matrix -> IO () 81 | matrixProjectBox (Matrix mat) box (OutputTransform transform) rotation (Matrix projection) = with box $ \boxPtr -> 82 | c_project_box mat boxPtr (fromIntegral transform) (CFloat rotation) projection 83 | 84 | 85 | printMatrix :: Handle -> Matrix -> IO () 86 | printMatrix handle (Matrix p) = do 87 | values :: [CFloat] <- mapM (peekElemOff p) [0 .. 8] 88 | hPutStrLn handle . show $ take 3 $ drop 0 values 89 | hPutStrLn handle . show $ take 3 $ drop 3 values 90 | hPutStrLn handle . show $ take 3 $ drop 6 values 91 | -------------------------------------------------------------------------------- /src/Graphics/Wayland/WlRoots/Screenshooter.hsc: -------------------------------------------------------------------------------- 1 | module Graphics.Wayland.WlRoots.Screenshooter 2 | ( WlrScreenshooter 3 | , screenshooterCreate 4 | , screenshooterDestroy 5 | , getScreenshooterGlobal 6 | ) 7 | where 8 | 9 | #define WLR_USE_UNSTABLE 10 | #include 11 | 12 | import Foreign.Ptr (Ptr) 13 | import Foreign.Storable (Storable (..)) 14 | 15 | import Graphics.Wayland.Server (DisplayServer(..)) 16 | import Graphics.Wayland.Global (WlGlobal) 17 | 18 | import Graphics.Wayland.WlRoots.Render (Renderer) 19 | 20 | data WlrScreenshooter 21 | 22 | foreign import ccall "wlr_screenshooter_create" c_create :: Ptr DisplayServer -> Ptr Renderer -> IO (Ptr WlrScreenshooter) 23 | 24 | screenshooterCreate :: DisplayServer -> Ptr Renderer -> IO (Ptr WlrScreenshooter) 25 | screenshooterCreate (DisplayServer dsp) rend = c_create dsp rend 26 | 27 | foreign import ccall "wlr_screenshooter_destroy" c_destroy :: Ptr WlrScreenshooter -> IO () 28 | 29 | screenshooterDestroy :: Ptr WlrScreenshooter -> IO () 30 | screenshooterDestroy = c_destroy 31 | 32 | getScreenshooterGlobal :: Ptr WlrScreenshooter -> IO (Ptr WlGlobal) 33 | getScreenshooterGlobal = #{peek struct wlr_screenshooter, global} 34 | -------------------------------------------------------------------------------- /src/Graphics/Wayland/WlRoots/ServerDecoration.hsc: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | module Graphics.Wayland.WlRoots.ServerDecoration 3 | ( ServerDecorationMode (..) 4 | , WlrServerDecorationManager 5 | , DecorationManagerEvents (..) 6 | , WlrServerDecoration 7 | , ServerDecorationEvents (..) 8 | 9 | , setDefaultDecorationMode 10 | , destroyServerDecorationManager 11 | , createServerDecorationManager 12 | , getDecorationManagerEvents 13 | , getServerDecorationMode 14 | , getServerDecorationEvents 15 | ) 16 | where 17 | 18 | #define WLR_USE_UNSTABLE 19 | #include 20 | 21 | import Data.Word (Word32) 22 | import Foreign.C.Error (throwErrnoIfNull) 23 | import Foreign.Ptr (Ptr, plusPtr) 24 | import Foreign.Storable (Storable (..)) 25 | import Graphics.Wayland.Server (DisplayServer (..)) 26 | import Graphics.Wayland.Signal (WlSignal) 27 | 28 | data ServerDecorationMode 29 | = SDModeNone 30 | | SDModeClient 31 | | SDModeServer 32 | deriving (Show, Eq) 33 | 34 | sDModeToInt :: Num a => ServerDecorationMode -> a 35 | sDModeToInt SDModeNone = #{const WLR_SERVER_DECORATION_MANAGER_MODE_NONE} 36 | sDModeToInt SDModeClient = #{const WLR_SERVER_DECORATION_MANAGER_MODE_CLIENT} 37 | sDModeToInt SDModeServer = #{const WLR_SERVER_DECORATION_MANAGER_MODE_SERVER} 38 | 39 | intToSDMode :: (Num a, Eq a, Show a) => a -> ServerDecorationMode 40 | intToSDMode #{const WLR_SERVER_DECORATION_MANAGER_MODE_NONE} = SDModeNone 41 | intToSDMode #{const WLR_SERVER_DECORATION_MANAGER_MODE_CLIENT} = SDModeClient 42 | intToSDMode #{const WLR_SERVER_DECORATION_MANAGER_MODE_SERVER} = SDModeServer 43 | intToSDMode x = error $ "Found invalid ServerDeocrationMode: " ++ show x 44 | 45 | data WlrServerDecorationManager 46 | 47 | data DecorationManagerEvents = DecorationManagerEvents 48 | { decorationManagerEvtNew :: Ptr (WlSignal WlrServerDecoration) 49 | } 50 | 51 | getDecorationManagerEvents :: Ptr WlrServerDecorationManager -> DecorationManagerEvents 52 | getDecorationManagerEvents ptr = DecorationManagerEvents 53 | { decorationManagerEvtNew = #{ptr struct wlr_server_decoration_manager, events.new_decoration} ptr 54 | } 55 | 56 | 57 | foreign import ccall unsafe "wlr_server_decoration_manager_create" c_create :: Ptr DisplayServer -> IO (Ptr WlrServerDecorationManager) 58 | 59 | createServerDecorationManager :: DisplayServer -> IO (Ptr WlrServerDecorationManager) 60 | createServerDecorationManager (DisplayServer ptr) = 61 | throwErrnoIfNull "createServerDecorationManager" $ c_create ptr 62 | 63 | 64 | foreign import ccall unsafe "wlr_server_decoration_manager_destroy" c_destroy :: Ptr WlrServerDecorationManager -> IO () 65 | 66 | 67 | destroyServerDecorationManager :: Ptr WlrServerDecorationManager -> IO () 68 | destroyServerDecorationManager = c_destroy 69 | 70 | -- void wlr_server_decoration_manager_set_default_mode( 71 | -- struct wlr_server_decoration_manager *manager, uint32_t default_mode); 72 | 73 | foreign import ccall unsafe "wlr_server_decoration_manager_set_default_mode" c_set_default_mode :: Ptr WlrServerDecorationManager -> Word32 -> IO () 74 | 75 | setDefaultDecorationMode :: Ptr WlrServerDecorationManager -> ServerDecorationMode -> IO () 76 | setDefaultDecorationMode ptr mode = c_set_default_mode ptr $ sDModeToInt mode 77 | 78 | data WlrServerDecoration 79 | 80 | getServerDecorationMode :: Ptr WlrServerDecoration -> IO ServerDecorationMode 81 | getServerDecorationMode ptr = do 82 | val :: Word32 <- #{peek struct wlr_server_decoration, mode} ptr 83 | pure $ intToSDMode val 84 | 85 | data ServerDecorationEvents = ServerDecorationEvents 86 | { serverDecorationEvtDestroy :: Ptr (WlSignal WlrServerDecoration) 87 | , serverDecorationEvtMode :: Ptr (WlSignal WlrServerDecoration) 88 | } 89 | 90 | getServerDecorationEvents :: Ptr WlrServerDecoration -> ServerDecorationEvents 91 | getServerDecorationEvents ptr = ServerDecorationEvents 92 | { serverDecorationEvtDestroy = #{ptr struct wlr_server_decoration, events.destroy} ptr 93 | , serverDecorationEvtMode = #{ptr struct wlr_server_decoration, events.mode} ptr 94 | } 95 | 96 | -------------------------------------------------------------------------------- /src/Graphics/Wayland/WlRoots/Surface.hsc: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE EmptyDataDecls #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | {-# LANGUAGE TupleSections #-} 4 | module Graphics.Wayland.WlRoots.Surface 5 | ( WlrSurface 6 | , surfaceGetTexture 7 | 8 | , createSurface 9 | , surfaceGetRoot 10 | 11 | , WlrSurfaceState 12 | 13 | , WlrFrameCallback 14 | , callbackGetResource 15 | , surfaceGetCallbacks 16 | , callbackGetCallback 17 | 18 | , getPendingState 19 | , getCurrentState 20 | 21 | , WlrSubSurface 22 | , subSurfaceGetSurface 23 | , surfaceGetSubs 24 | , subSurfaceGetBox 25 | , surfaceGetInputRegion 26 | 27 | , getSurfaceResource 28 | , surfaceAt 29 | , surfaceHasDamage 30 | 31 | , WlrSurfaceEvents (..) 32 | , getWlrSurfaceEvents 33 | 34 | , surfaceGetScale 35 | , surfaceGetSize 36 | , surfaceSendEnter 37 | , surfaceSendLeave 38 | , getSurfaceDamage 39 | , subSurfaceGetDestroyEvent 40 | , surfaceGetTransform 41 | 42 | , pokeSurfaceData 43 | , peekSurfaceData 44 | 45 | , surfaceFromResource 46 | , surfaceHasBuffer 47 | , surfaceGetBuffer 48 | ) 49 | where 50 | 51 | #define WLR_USE_UNSTABLE 52 | #include 53 | 54 | import Data.Composition ((.:)) 55 | import Data.Int (Int32) 56 | import Data.Word (Word8, Word32) 57 | import Foreign.C.Error (throwErrnoIfNull) 58 | import Foreign.C.Types (CInt(..)) 59 | import Foreign.Ptr (Ptr, castPtr, plusPtr, nullPtr) 60 | import Foreign.Storable (Storable(..)) 61 | import Foreign.Marshal.Alloc (alloca) 62 | 63 | import Graphics.Pixman (PixmanRegion32 (..), pixmanRegionNotEmpty) 64 | import Graphics.Wayland.Signal 65 | import Graphics.Wayland.Server (Callback(..), OutputTransform (..)) 66 | 67 | import Graphics.Wayland.List (getListFromHead, getListElems, WlList) 68 | import Graphics.Wayland.Resource (WlResource) 69 | import Graphics.Wayland.WlRoots.Box (WlrBox(..), Point (..)) 70 | import Graphics.Wayland.WlRoots.Output (WlrOutput) 71 | import Graphics.Wayland.WlRoots.Render (Texture, Renderer) 72 | import Graphics.Wayland.WlRoots.Buffer (WlrBuffer (..)) 73 | 74 | data WlrSurface 75 | 76 | pokeSurfaceData :: Ptr WlrSurface -> Ptr a -> IO () 77 | pokeSurfaceData = #{poke struct wlr_surface, data} 78 | 79 | peekSurfaceData :: Ptr WlrSurface -> IO (Ptr a) 80 | peekSurfaceData = #{peek struct wlr_surface, data} 81 | 82 | foreign import ccall unsafe "wlr_surface_create" c_create :: Ptr WlResource -> Ptr Renderer -> IO (Ptr WlrSurface) 83 | 84 | createSurface :: Ptr WlResource -> Ptr Renderer -> IO (Ptr WlrSurface) 85 | createSurface = throwErrnoIfNull "createSurface" .: c_create 86 | 87 | getSurfaceResource :: Ptr WlrSurface -> IO (Ptr WlResource) 88 | getSurfaceResource = #{peek struct wlr_surface, resource} 89 | 90 | data WlrSurfaceEvents = WlrSurfaceEvents 91 | { wlrSurfaceEvtCommit :: Ptr (WlSignal WlrSurface) 92 | , wlrSurfaceEvtSubSurf :: Ptr (WlSignal WlrSubSurface) 93 | , wlrSurfaceEvtDestroy :: Ptr (WlSignal WlrSurface) 94 | } 95 | 96 | getWlrSurfaceEvents :: Ptr WlrSurface -> WlrSurfaceEvents 97 | getWlrSurfaceEvents ptr = WlrSurfaceEvents 98 | { wlrSurfaceEvtDestroy = #{ptr struct wlr_surface, events.destroy} ptr 99 | , wlrSurfaceEvtSubSurf = #{ptr struct wlr_surface, events.new_subsurface} ptr 100 | , wlrSurfaceEvtCommit = #{ptr struct wlr_surface, events.commit} ptr 101 | } 102 | 103 | foreign import ccall unsafe "wlr_surface_get_texture" c_get_texture :: Ptr WlrSurface -> IO (Ptr Texture) 104 | 105 | surfaceGetTexture :: Ptr WlrSurface -> IO (Maybe (Ptr Texture)) 106 | surfaceGetTexture ptr = do 107 | ret <- c_get_texture ptr 108 | pure $ if ret == nullPtr 109 | then Nothing 110 | else Just ret 111 | 112 | foreign import ccall unsafe "wlr_surface_get_root_surface" c_get_root_surface :: Ptr WlrSurface -> IO (Ptr WlrSurface) 113 | 114 | surfaceGetRoot :: Ptr WlrSurface -> IO (Ptr WlrSurface) 115 | surfaceGetRoot = c_get_root_surface 116 | 117 | 118 | data WlrSurfaceState 119 | 120 | stateGetTransform :: Ptr WlrSurfaceState -> IO OutputTransform 121 | stateGetTransform = fmap OutputTransform . #{peek struct wlr_surface_state, transform} 122 | 123 | surfaceGetTransform :: Ptr WlrSurface -> IO OutputTransform 124 | surfaceGetTransform = stateGetTransform . getCurrentState 125 | 126 | stateGetScale :: Ptr WlrSurfaceState -> IO Word32 127 | stateGetScale = #{peek struct wlr_surface_state, scale} 128 | 129 | surfaceGetScale :: Ptr WlrSurface -> IO Word32 130 | surfaceGetScale = stateGetScale . getCurrentState 131 | 132 | stateGetInputRegion :: Ptr WlrSurfaceState -> Ptr PixmanRegion32 133 | stateGetInputRegion = #{ptr struct wlr_surface_state, input} 134 | 135 | surfaceGetInputRegion :: Ptr WlrSurface -> Ptr PixmanRegion32 136 | surfaceGetInputRegion = stateGetInputRegion . getCurrentState 137 | 138 | stateGetSize :: Ptr WlrSurfaceState -> IO Point 139 | stateGetSize state = do 140 | width :: CInt <- #{peek struct wlr_surface_state, width} state 141 | height :: CInt <- #{peek struct wlr_surface_state, height} state 142 | 143 | pure $ Point (fromIntegral width) (fromIntegral height) 144 | 145 | surfaceGetSize :: Ptr WlrSurface -> IO Point 146 | surfaceGetSize = stateGetSize . getCurrentState 147 | 148 | newtype WlrFrameCallback = WlrFrameCallback (Ptr WlList) 149 | foreign import ccall unsafe "wl_resource_from_link" c_resource_from_link :: Ptr WlList -> IO (Ptr WlResource) 150 | 151 | callbackGetResource :: WlrFrameCallback -> IO (Ptr WlResource) 152 | callbackGetResource (WlrFrameCallback ptr) = 153 | c_resource_from_link ptr 154 | 155 | surfaceGetCallbacks :: Ptr WlrSurfaceState -> IO [WlrFrameCallback] 156 | surfaceGetCallbacks ptr = 157 | let list = #{ptr struct wlr_surface_state, frame_callback_list} ptr 158 | in fmap WlrFrameCallback <$> getListElems list 159 | 160 | callbackGetCallback :: WlrFrameCallback -> IO Callback 161 | callbackGetCallback = fmap (Callback . castPtr) . callbackGetResource 162 | 163 | 164 | getPendingState :: Ptr WlrSurface -> IO (Ptr WlrSurfaceState) 165 | getPendingState = #{peek struct wlr_surface, pending} 166 | 167 | getCurrentState :: Ptr WlrSurface -> Ptr WlrSurfaceState 168 | getCurrentState = #{ptr struct wlr_surface, current} 169 | 170 | stateHasDamage :: Ptr WlrSurfaceState -> IO Bool 171 | stateHasDamage ptr = pixmanRegionNotEmpty . PixmanRegion32 $ #{ptr struct wlr_surface_state, surface_damage} ptr 172 | 173 | surfaceHasDamage :: Ptr WlrSurface -> IO Bool 174 | surfaceHasDamage = stateHasDamage . getCurrentState 175 | 176 | getStateDamage :: Ptr WlrSurfaceState -> Ptr PixmanRegion32 177 | getStateDamage = #{ptr struct wlr_surface_state, surface_damage} 178 | 179 | getSurfaceDamage :: Ptr WlrSurface -> IO (Maybe PixmanRegion32) 180 | getSurfaceDamage surf = do 181 | let state = getCurrentState surf 182 | hasDamage <- stateHasDamage state 183 | pure $ if hasDamage 184 | then Just . PixmanRegion32 $ getStateDamage state 185 | else Nothing 186 | 187 | data WlrSubSurface 188 | 189 | subSurfaceGetDestroyEvent :: Ptr WlrSubSurface -> Ptr (WlSignal WlrSubSurface) 190 | subSurfaceGetDestroyEvent = #{ptr struct wlr_subsurface, events.destroy} 191 | 192 | subSurfaceGetSurface :: Ptr WlrSubSurface -> IO (Ptr WlrSurface) 193 | subSurfaceGetSurface = #{peek struct wlr_subsurface, surface} 194 | 195 | surfaceGetSubs :: Ptr WlrSurface -> IO [Ptr WlrSubSurface] 196 | surfaceGetSubs surf = do 197 | let list = #{ptr struct wlr_surface, subsurfaces} surf 198 | getListFromHead list #{offset struct wlr_subsurface, parent_link} 199 | 200 | subSurfaceGetBox :: Ptr WlrSubSurface -> IO WlrBox 201 | subSurfaceGetBox surf = do 202 | Point w h <- surfaceGetSize =<< subSurfaceGetSurface surf 203 | let subsurfState = #{ptr struct wlr_subsurface, current} surf 204 | x :: Int32 <- #{peek struct wlr_subsurface_state, x} subsurfState 205 | y :: Int32 <- #{peek struct wlr_subsurface_state, y} subsurfState 206 | 207 | pure $ WlrBox (fromIntegral x) (fromIntegral y) w h 208 | 209 | foreign import ccall "wlr_surface_surface_at" c_subsurface_at :: Ptr WlrSurface -> Double -> Double -> Ptr Double -> Ptr Double -> IO (Ptr WlrSurface) 210 | 211 | surfaceAt :: Ptr WlrSurface -> Double -> Double -> IO (Maybe (Ptr WlrSurface, Double, Double)) 212 | surfaceAt surf x y = alloca $ \xptr -> alloca $ \yptr -> do 213 | ret <- c_subsurface_at surf x y xptr yptr 214 | if ret == nullPtr 215 | then pure Nothing 216 | else do 217 | sX <- peek xptr 218 | sY <- peek yptr 219 | pure $ Just (ret, sX, sY) 220 | 221 | foreign import ccall "wlr_surface_send_enter" c_send_enter :: Ptr WlrSurface -> Ptr WlrOutput -> IO () 222 | 223 | surfaceSendEnter :: Ptr WlrSurface -> Ptr WlrOutput -> IO () 224 | surfaceSendEnter = c_send_enter 225 | 226 | foreign import ccall "wlr_surface_send_leave" c_send_leave :: Ptr WlrSurface -> Ptr WlrOutput -> IO () 227 | 228 | surfaceSendLeave :: Ptr WlrSurface -> Ptr WlrOutput -> IO () 229 | surfaceSendLeave = c_send_leave 230 | 231 | foreign import ccall "wlr_surface_from_resource" c_from_resource :: Ptr WlResource -> IO (Ptr WlrSurface) 232 | 233 | surfaceFromResource :: Ptr WlResource -> IO (Ptr WlrSurface) 234 | surfaceFromResource = c_from_resource 235 | 236 | foreign import ccall "wlr_surface_has_buffer" c_has_buffer :: Ptr WlrSurface -> IO Word8 237 | 238 | surfaceHasBuffer :: Ptr WlrSurface -> IO Bool 239 | surfaceHasBuffer = fmap (/= 0) . c_has_buffer 240 | 241 | surfaceGetBuffer :: Ptr WlrSurface -> IO (WlrBuffer) 242 | surfaceGetBuffer = fmap WlrBuffer . #{peek struct wlr_surface, buffer} 243 | -------------------------------------------------------------------------------- /src/Graphics/Wayland/WlRoots/SurfaceLayers.hsc: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | module Graphics.Wayland.WlRoots.SurfaceLayers 3 | ( LayerShell (..) 4 | , LayerShellEvents (..) 5 | , SurfaceState (..) 6 | , LayerSurface (..) 7 | , LayerShellLayer (..) 8 | , getLayerShellEvents 9 | , layerShellCreate 10 | , layerShellDestroy 11 | 12 | , configureSurface 13 | , closeSurface 14 | 15 | , getLayerSurfaceLayer 16 | , LayerSurfaceEvents (..) 17 | , getLayerSurfaceEvents 18 | 19 | , getSurfaceState 20 | 21 | , Anchor (..) 22 | , getAnchorValue 23 | , getMainAnchor 24 | , useHeight, useWidth 25 | , getSurfaceOutput 26 | , setSurfaceOutput 27 | , getLayerSurfaceSurface 28 | 29 | , Corner (..), getAnchorCorner 30 | 31 | , getPopups 32 | ) 33 | where 34 | 35 | #define WLR_USE_UNSTABLE 36 | #include 37 | #include 38 | 39 | import Data.Bits (Bits((.&.))) 40 | import Data.Word (Word32) 41 | import Data.Int (Int32) 42 | import Foreign.C.Types (CInt) 43 | import Foreign.C.Error (throwErrnoIfNull) 44 | import Foreign.Ptr (Ptr, plusPtr, nullPtr) 45 | import Foreign.Storable 46 | 47 | import Graphics.Wayland.Server (DisplayServer (..)) 48 | 49 | import Graphics.Wayland.List (getListFromHead) 50 | import Graphics.Wayland.Signal (WlSignal) 51 | import Graphics.Wayland.WlRoots.Output (WlrOutput) 52 | import Graphics.Wayland.WlRoots.Surface (WlrSurface) 53 | 54 | import Graphics.Wayland.WlRoots.XdgShell (WlrXdgPopup) 55 | 56 | data LayerShellLayer 57 | = LayerShellLayerBackground 58 | | LayerShellLayerBottom 59 | | LayerShellLayerTop 60 | | LayerShellLayerOverlay 61 | deriving (Eq, Show, Ord) 62 | 63 | data Anchor 64 | = AnchorTop 65 | | AnchorBottom 66 | | AnchorLeft 67 | | AnchorRight 68 | deriving (Eq, Show) 69 | 70 | useHeight :: SurfaceState -> Word32 -> Word32 71 | useHeight state box = 72 | let full = box - surfaceStateMarginBottom state - surfaceStateMarginTop state 73 | in case surfaceStateAnchor state .&. #{const ZWLR_LAYER_SURFACE_V1_ANCHOR_BOTTOM | ZWLR_LAYER_SURFACE_V1_ANCHOR_TOP} of 74 | #{const ZWLR_LAYER_SURFACE_V1_ANCHOR_BOTTOM | ZWLR_LAYER_SURFACE_V1_ANCHOR_TOP} -> full 75 | _ -> min full (surfaceStateDesiredHeight state) 76 | 77 | useWidth :: SurfaceState -> Word32 -> Word32 78 | useWidth state box = 79 | let full = box - surfaceStateMarginLeft state - surfaceStateMarginTop state 80 | in case surfaceStateAnchor state .&. #{const ZWLR_LAYER_SURFACE_V1_ANCHOR_LEFT | ZWLR_LAYER_SURFACE_V1_ANCHOR_RIGHT} of 81 | #{const ZWLR_LAYER_SURFACE_V1_ANCHOR_LEFT | ZWLR_LAYER_SURFACE_V1_ANCHOR_RIGHT} -> full 82 | _ -> min full (surfaceStateDesiredWidth state) 83 | 84 | getMainAnchor :: (Num a, Eq a) => a -> Maybe Anchor 85 | getMainAnchor #{const ZWLR_LAYER_SURFACE_V1_ANCHOR_BOTTOM} = Just AnchorBottom 86 | getMainAnchor #{const ZWLR_LAYER_SURFACE_V1_ANCHOR_TOP} = Just AnchorTop 87 | getMainAnchor #{const ZWLR_LAYER_SURFACE_V1_ANCHOR_LEFT} = Just AnchorLeft 88 | getMainAnchor #{const ZWLR_LAYER_SURFACE_V1_ANCHOR_RIGHT} = Just AnchorRight 89 | getMainAnchor #{const ZWLR_LAYER_SURFACE_V1_ANCHOR_BOTTOM | ZWLR_LAYER_SURFACE_V1_ANCHOR_RIGHT | ZWLR_LAYER_SURFACE_V1_ANCHOR_LEFT} = Just AnchorBottom 90 | getMainAnchor #{const ZWLR_LAYER_SURFACE_V1_ANCHOR_TOP | ZWLR_LAYER_SURFACE_V1_ANCHOR_RIGHT | ZWLR_LAYER_SURFACE_V1_ANCHOR_LEFT} = Just AnchorTop 91 | getMainAnchor #{const ZWLR_LAYER_SURFACE_V1_ANCHOR_LEFT | ZWLR_LAYER_SURFACE_V1_ANCHOR_BOTTOM | ZWLR_LAYER_SURFACE_V1_ANCHOR_TOP} = Just AnchorLeft 92 | getMainAnchor #{const ZWLR_LAYER_SURFACE_V1_ANCHOR_RIGHT | ZWLR_LAYER_SURFACE_V1_ANCHOR_BOTTOM | ZWLR_LAYER_SURFACE_V1_ANCHOR_TOP} = Just AnchorRight 93 | getMainAnchor _ = Nothing 94 | 95 | data Corner 96 | = TopLeft 97 | | TopRight 98 | | BottomLeft 99 | | BottomRight 100 | deriving (Eq, Show) 101 | 102 | getAnchorCorner :: (Num a, Eq a) => a -> Maybe Corner 103 | getAnchorCorner #{const ZWLR_LAYER_SURFACE_V1_ANCHOR_TOP | ZWLR_LAYER_SURFACE_V1_ANCHOR_LEFT} = Just TopLeft 104 | getAnchorCorner #{const ZWLR_LAYER_SURFACE_V1_ANCHOR_TOP | ZWLR_LAYER_SURFACE_V1_ANCHOR_RIGHT} = Just TopRight 105 | getAnchorCorner #{const ZWLR_LAYER_SURFACE_V1_ANCHOR_BOTTOM | ZWLR_LAYER_SURFACE_V1_ANCHOR_LEFT} = Just BottomLeft 106 | getAnchorCorner #{const ZWLR_LAYER_SURFACE_V1_ANCHOR_BOTTOM | ZWLR_LAYER_SURFACE_V1_ANCHOR_RIGHT} = Just BottomRight 107 | getAnchorCorner _ = Nothing 108 | 109 | 110 | 111 | getAnchorValue :: Num a => Anchor -> a 112 | getAnchorValue AnchorBottom = #{const ZWLR_LAYER_SURFACE_V1_ANCHOR_BOTTOM} 113 | getAnchorValue AnchorTop = #{const ZWLR_LAYER_SURFACE_V1_ANCHOR_TOP} 114 | getAnchorValue AnchorLeft = #{const ZWLR_LAYER_SURFACE_V1_ANCHOR_LEFT} 115 | getAnchorValue AnchorRight = #{const ZWLR_LAYER_SURFACE_V1_ANCHOR_RIGHT} 116 | 117 | 118 | data LayerShell = LayerShell { unLS :: Ptr LayerShell } 119 | data LayerSurface = LayerSurface { unLSS :: Ptr LayerSurface } deriving (Eq, Show, Ord) 120 | 121 | data LayerShellEvents = LayerShellEvents 122 | { layerShellEventsSurface :: Ptr (WlSignal LayerSurface) 123 | } 124 | 125 | getLayerShellEvents :: LayerShell -> LayerShellEvents 126 | getLayerShellEvents (LayerShell ptr) = LayerShellEvents 127 | { layerShellEventsSurface = #{ptr struct wlr_layer_shell_v1, events.new_surface} ptr 128 | } 129 | 130 | data SurfaceState = SurfaceState 131 | { surfaceStateAnchor :: Word32 -- TODO: Make list of enum 132 | , surfaceStateExclusive :: Int32 133 | , surfaceStateMarginTop :: Word32 134 | , surfaceStateMarginBottom :: Word32 135 | , surfaceStateMarginLeft :: Word32 136 | , surfaceStateMarginRight :: Word32 137 | , surfaceStateKeyboard :: Bool 138 | , surfaceStateDesiredWidth :: Word32 139 | , surfaceStateDesiredHeight :: Word32 140 | , surfaceStateActualWidth :: Word32 141 | , surfaceStateActualHeight :: Word32 142 | } 143 | 144 | foreign import ccall unsafe "wlr_layer_shell_v1_create" c_create :: Ptr DisplayServer -> IO (Ptr LayerShell) 145 | 146 | layerShellCreate :: DisplayServer -> IO LayerShell 147 | layerShellCreate (DisplayServer dsp) = LayerShell <$> 148 | throwErrnoIfNull "layerShellCreate" (c_create dsp) 149 | 150 | foreign import ccall "wlr_layer_shell_v1_destroy" c_destroy :: Ptr LayerShell -> IO () 151 | 152 | layerShellDestroy :: LayerShell -> IO () 153 | layerShellDestroy = c_destroy . unLS 154 | 155 | foreign import ccall unsafe "wlr_layer_surface_v1_configure" c_configure :: Ptr LayerSurface -> Word32 -> Word32 -> IO () 156 | 157 | configureSurface :: LayerSurface -> Word32 -> Word32 -> IO () 158 | configureSurface (LayerSurface ptr) width height = c_configure ptr width height 159 | 160 | foreign import ccall unsafe "wlr_layer_surface_v1_close" c_close :: Ptr LayerSurface -> IO () 161 | 162 | closeSurface :: LayerSurface -> IO () 163 | closeSurface = c_close . unLSS 164 | 165 | data LayerSurfaceEvents = LayerSurfaceEvents 166 | { layerSurfaceEventsDestroy :: Ptr (WlSignal LayerSurface) 167 | , layerSurfaceEventsMap :: Ptr (WlSignal LayerSurface) 168 | , layerSurfaceEventsUnmap :: Ptr (WlSignal LayerSurface) 169 | , layerSurfaceEventsPopup :: Ptr (WlSignal WlrXdgPopup) 170 | } 171 | 172 | getLayerSurfaceEvents :: LayerSurface -> LayerSurfaceEvents 173 | getLayerSurfaceEvents (LayerSurface ptr) = LayerSurfaceEvents 174 | { layerSurfaceEventsDestroy = #{ptr struct wlr_layer_surface_v1, events.destroy} ptr 175 | , layerSurfaceEventsMap = #{ptr struct wlr_layer_surface_v1, events.map} ptr 176 | , layerSurfaceEventsUnmap = #{ptr struct wlr_layer_surface_v1, events.unmap} ptr 177 | , layerSurfaceEventsPopup = #{ptr struct wlr_layer_surface_v1, events.new_popup} ptr 178 | } 179 | 180 | 181 | getLayerSurfaceLayer :: LayerSurface -> IO LayerShellLayer 182 | getLayerSurfaceLayer (LayerSurface ptr) = do 183 | layer :: CInt <- #{peek struct wlr_layer_surface_v1, layer} ptr 184 | pure $ case layer of 185 | #{const ZWLR_LAYER_SHELL_V1_LAYER_BACKGROUND} -> LayerShellLayerBackground 186 | #{const ZWLR_LAYER_SHELL_V1_LAYER_BOTTOM} -> LayerShellLayerBottom 187 | #{const ZWLR_LAYER_SHELL_V1_LAYER_TOP} -> LayerShellLayerTop 188 | #{const ZWLR_LAYER_SHELL_V1_LAYER_OVERLAY} -> LayerShellLayerOverlay 189 | _ -> LayerShellLayerBottom 190 | 191 | 192 | instance Storable SurfaceState where 193 | sizeOf _ = #{size struct wlr_layer_surface_v1_state} 194 | alignment _ = #{alignment struct wlr_layer_surface_v1_state} 195 | peek ptr = SurfaceState 196 | <$> #{peek struct wlr_layer_surface_v1_state, anchor} ptr 197 | <*> #{peek struct wlr_layer_surface_v1_state, exclusive_zone} ptr 198 | <*> #{peek struct wlr_layer_surface_v1_state, margin.top} ptr 199 | <*> #{peek struct wlr_layer_surface_v1_state, margin.bottom} ptr 200 | <*> #{peek struct wlr_layer_surface_v1_state, margin.left} ptr 201 | <*> #{peek struct wlr_layer_surface_v1_state, margin.right} ptr 202 | <*> #{peek struct wlr_layer_surface_v1_state, keyboard_interactive} ptr 203 | <*> #{peek struct wlr_layer_surface_v1_state, desired_width} ptr 204 | <*> #{peek struct wlr_layer_surface_v1_state, desired_height} ptr 205 | <*> #{peek struct wlr_layer_surface_v1_state, actual_width} ptr 206 | <*> #{peek struct wlr_layer_surface_v1_state, actual_height} ptr 207 | poke = error "No reason to poke LayerShell SurfaceStates for now" 208 | 209 | getSurfaceState :: LayerSurface -> IO SurfaceState 210 | getSurfaceState = #{peek struct wlr_layer_surface_v1, current} . unLSS 211 | 212 | 213 | getSurfaceOutput :: LayerSurface -> IO (Ptr WlrOutput) 214 | getSurfaceOutput = #{peek struct wlr_layer_surface_v1, output} . unLSS 215 | 216 | setSurfaceOutput :: LayerSurface -> Ptr WlrOutput -> IO () 217 | setSurfaceOutput surf out = #{poke struct wlr_layer_surface_v1, output} (unLSS surf) out 218 | 219 | getLayerSurfaceSurface :: LayerSurface -> IO (Maybe (Ptr WlrSurface)) 220 | getLayerSurfaceSurface (LayerSurface ptr) = do 221 | ret <- #{peek struct wlr_layer_surface_v1, surface} ptr 222 | pure $ case ret /= nullPtr of 223 | True -> Just ret 224 | False -> Nothing 225 | 226 | getPopups :: LayerSurface -> IO [Ptr WlrXdgPopup] 227 | getPopups (LayerSurface surf) = do 228 | let list = #{ptr struct wlr_layer_surface_v1, popups} surf 229 | getListFromHead list #{offset struct wlr_xdg_popup, link} 230 | -------------------------------------------------------------------------------- /src/Graphics/Wayland/WlRoots/Tabletv2.hsc: -------------------------------------------------------------------------------- 1 | module Graphics.Wayland.WlRoots.Tabletv2 2 | ( TabletManagerv2 (..) 3 | , createTabletManagerv2 4 | 5 | , Tabletv2 (..) 6 | , createTabletv2 7 | 8 | , TabletPadv2 (..) 9 | , createTabletPadv2 10 | 11 | , TabletToolv2 (..) 12 | , createTabletToolv2 13 | 14 | , surfaceAcceptsTablet 15 | 16 | , sendTabletPadEnter 17 | , sendTabletPadLeave 18 | , sendTabletToolProximityIn 19 | , sendTabletToolProximityOut 20 | ) 21 | where 22 | 23 | 24 | #define WLR_USE_UNSTABLE 25 | #include 26 | 27 | import Data.Word (Word8, Word32) 28 | import Foreign.Ptr (Ptr) 29 | import Foreign.Storable 30 | import Foreign.C.Error (throwErrnoIfNull) 31 | 32 | import Graphics.Wayland.Server (DisplayServer (..)) 33 | import Graphics.Wayland.WlRoots.Global 34 | import Graphics.Wayland.WlRoots.Input (InputDevice) 35 | import Graphics.Wayland.WlRoots.Input.TabletTool (WlrTabletTool (..)) 36 | import Graphics.Wayland.WlRoots.Seat (WlrSeat) 37 | import Graphics.Wayland.WlRoots.Surface (WlrSurface) 38 | 39 | 40 | newtype TabletManagerv2 = TabletManagerv2 (Ptr TabletManagerv2) 41 | 42 | foreign import ccall unsafe "wlr_tablet_v2_create" c_create_manager :: Ptr DisplayServer -> IO (Ptr TabletManagerv2) 43 | foreign import ccall safe "wlr_tablet_v2_destroy" c_destroy_manager :: Ptr TabletManagerv2 -> IO () 44 | 45 | createTabletManagerv2 :: DisplayServer -> IO TabletManagerv2 46 | createTabletManagerv2 (DisplayServer dsp) = 47 | TabletManagerv2 <$> throwErrnoIfNull "createTabletManagerv2" (c_create_manager dsp) 48 | 49 | instance GlobalWrapper TabletManagerv2 where 50 | getGlobal (TabletManagerv2 ptr) = #{peek struct wlr_tablet_manager_v2, wl_global} ptr 51 | removeGlobal (TabletManagerv2 ptr) = c_destroy_manager ptr 52 | 53 | 54 | newtype Tabletv2 = Tabletv2 (Ptr Tabletv2) deriving (Eq, Ord, Show) 55 | 56 | foreign import ccall unsafe "wlr_tablet_create" c_create_tablet :: Ptr TabletManagerv2 -> Ptr WlrSeat -> Ptr InputDevice -> IO (Ptr Tabletv2) 57 | createTabletv2 :: TabletManagerv2 -> Ptr WlrSeat -> Ptr InputDevice -> IO Tabletv2 58 | createTabletv2 (TabletManagerv2 mgr) seat iDev = 59 | Tabletv2 <$> throwErrnoIfNull "createTabletv2" (c_create_tablet mgr seat iDev) 60 | 61 | 62 | newtype TabletPadv2 = TabletPadv2 (Ptr TabletPadv2) deriving (Eq, Ord, Show) 63 | 64 | foreign import ccall unsafe "wlr_tablet_pad_create" c_create_tablet_pad :: Ptr TabletManagerv2 -> Ptr WlrSeat -> Ptr InputDevice -> IO (Ptr TabletPadv2) 65 | createTabletPadv2 :: TabletManagerv2 -> Ptr WlrSeat -> Ptr InputDevice -> IO TabletPadv2 66 | createTabletPadv2 (TabletManagerv2 mgr) seat iDev = 67 | TabletPadv2 <$> throwErrnoIfNull "createTabletPadv2" (c_create_tablet_pad mgr seat iDev) 68 | 69 | newtype TabletToolv2 = TabletToolv2 (Ptr TabletToolv2) deriving (Eq, Ord, Show) 70 | 71 | foreign import ccall unsafe "wlr_tablet_tool_create" c_create_tablet_tool :: Ptr TabletManagerv2 -> Ptr WlrSeat -> Ptr WlrTabletTool -> IO (Ptr TabletToolv2) 72 | createTabletToolv2 :: TabletManagerv2 -> Ptr WlrSeat -> WlrTabletTool -> IO TabletToolv2 73 | createTabletToolv2 (TabletManagerv2 mgr) seat (WlrTabletTool tool) = 74 | TabletToolv2 <$> throwErrnoIfNull "createTabletToolv2" (c_create_tablet_tool mgr seat tool) 75 | 76 | 77 | foreign import ccall unsafe "wlr_surface_accepts_tablet_v2" c_accepts_tablet :: Ptr Tabletv2 -> Ptr WlrSurface -> IO Word8 78 | surfaceAcceptsTablet :: Tabletv2 -> Ptr WlrSurface -> IO Bool 79 | surfaceAcceptsTablet (Tabletv2 tablet) surf = (/= 0) <$> c_accepts_tablet tablet surf 80 | 81 | foreign import ccall "wlr_send_tablet_v2_tablet_pad_enter" c_send_pad_enter :: Ptr TabletPadv2 -> Ptr Tabletv2 -> Ptr WlrSurface -> IO Word32 82 | sendTabletPadEnter :: TabletPadv2 -> Tabletv2 -> Ptr WlrSurface -> IO Word32 83 | sendTabletPadEnter (TabletPadv2 pad) (Tabletv2 tablet) surf = c_send_pad_enter pad tablet surf 84 | 85 | foreign import ccall "wlr_send_tablet_v2_tablet_pad_leave" c_send_pad_leave :: Ptr TabletPadv2 -> Ptr WlrSurface -> IO Word32 86 | sendTabletPadLeave :: TabletPadv2 -> Ptr WlrSurface -> IO Word32 87 | sendTabletPadLeave (TabletPadv2 pad) surf = c_send_pad_leave pad surf 88 | 89 | 90 | foreign import ccall "wlr_send_tablet_v2_tablet_tool_proximity_in" c_send_proximity_in :: Ptr TabletToolv2 -> Ptr Tabletv2 -> Ptr WlrSurface -> IO () 91 | sendTabletToolProximityIn :: TabletToolv2 -> Tabletv2 -> Ptr WlrSurface -> IO () 92 | sendTabletToolProximityIn (TabletToolv2 tool) (Tabletv2 tablet) surf = c_send_proximity_in tool tablet surf 93 | 94 | foreign import ccall "wlr_send_tablet_v2_tablet_tool_proximity_out" c_send_proximity_out :: Ptr TabletToolv2 -> IO () 95 | sendTabletToolProximityOut :: TabletToolv2 -> IO () 96 | sendTabletToolProximityOut (TabletToolv2 tool) = c_send_proximity_out tool 97 | -------------------------------------------------------------------------------- /src/Graphics/Wayland/WlRoots/Util.hsc: -------------------------------------------------------------------------------- 1 | module Graphics.Wayland.WlRoots.Util 2 | ( LogPriority (..) 3 | , setLogPrio 4 | ) 5 | where 6 | 7 | #include 8 | 9 | import Foreign.C.Types (CInt (..)) 10 | import Foreign.Ptr (Ptr, nullPtr) 11 | 12 | data LogPriority 13 | = Silent 14 | | Error 15 | | Info 16 | | Debug 17 | deriving (Show, Eq) 18 | 19 | logPrioToInt :: Num a => LogPriority -> a 20 | logPrioToInt Silent = #{const WLR_SILENT} 21 | logPrioToInt Error = #{const WLR_ERROR} 22 | logPrioToInt Info = #{const WLR_INFO} 23 | logPrioToInt Debug = #{const WLR_DEBUG} 24 | 25 | foreign import ccall unsafe "wlr_log_init" c_log_init :: CInt -> Ptr a -> IO () 26 | 27 | setLogPrio :: LogPriority -> IO () 28 | setLogPrio prio = 29 | c_log_init (logPrioToInt prio) nullPtr 30 | -------------------------------------------------------------------------------- /src/Graphics/Wayland/WlRoots/Util/Region.hsc: -------------------------------------------------------------------------------- 1 | module Graphics.Wayland.WlRoots.Util.Region 2 | where 3 | 4 | import Foreign.C.Types (CFloat (..)) 5 | import Foreign.Ptr (Ptr) 6 | 7 | import Graphics.Pixman (PixmanRegion32, withRegion32) 8 | 9 | foreign import ccall unsafe "wlr_region_scale" c_scale :: Ptr PixmanRegion32 -> Ptr PixmanRegion32 -> CFloat -> IO () 10 | 11 | scaleRegion :: PixmanRegion32 -> Float -> IO () 12 | scaleRegion region scale = withRegion32 region $ \ptr -> 13 | c_scale ptr ptr (CFloat scale) 14 | -------------------------------------------------------------------------------- /src/Graphics/Wayland/WlRoots/WlShell.hsc: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TupleSections #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | module Graphics.Wayland.WlRoots.WlShell 4 | ( WlrWlShell (..) 5 | , shellCreate 6 | , shellDestroy 7 | 8 | , WlrWlShellSurface (..) 9 | , setWlShellListener 10 | 11 | 12 | , configureWlShellSurface 13 | , shellSurfaceAt 14 | , wlShellSurfaceGetSurface 15 | 16 | , getTitle 17 | , getClass 18 | 19 | , WlrWlSurfaceEvents (..) 20 | , getWlrWlSurfaceEvents 21 | , getWlShellPopups 22 | , isPopup 23 | , getTransientPosition 24 | 25 | , getClient 26 | ) 27 | where 28 | 29 | #define WLR_USE_UNSTABLE 30 | #include 31 | 32 | import Data.Composition ((.:)) 33 | import Data.Int (Int32) 34 | import Data.Text (Text) 35 | import Foreign.C.Error (throwErrnoIfNull) 36 | import Foreign.C.Types (CInt (..)) 37 | import Foreign.Marshal.Alloc (alloca) 38 | import Foreign.Ptr (Ptr, plusPtr, nullPtr) 39 | import Foreign.Storable (Storable(..)) 40 | 41 | import Graphics.Wayland.List (getListFromHead) 42 | import Graphics.Wayland.Server (DisplayServer(..), Client (..)) 43 | import Graphics.Wayland.Signal (WlSignal, addListener, WlListener (..), ListenerToken) 44 | import Graphics.Wayland.WlRoots.Surface (WlrSurface) 45 | import Utility (textFromNull) 46 | 47 | 48 | newtype WlrWlShell = WlrWlShell { unWlr :: Ptr WlrWlShell } 49 | 50 | foreign import ccall unsafe "wlr_wl_shell_create" c_shell_create :: Ptr DisplayServer -> IO (Ptr WlrWlShell) 51 | 52 | shellCreate :: DisplayServer -> IO WlrWlShell 53 | shellCreate (DisplayServer ptr) = 54 | WlrWlShell <$> (throwErrnoIfNull "shellCreate" $ c_shell_create ptr) 55 | 56 | foreign import ccall "wlr_wl_shell_destroy" c_shell_destroy :: Ptr WlrWlShell -> IO () 57 | 58 | shellDestroy :: WlrWlShell -> IO () 59 | shellDestroy = c_shell_destroy . unWlr 60 | 61 | 62 | newtype WlrWlShellSurface = WlrWlShellSurface { unWlrSurf :: Ptr WlrWlShellSurface } 63 | 64 | setWlShellListener :: WlrWlShell -> (WlrWlShellSurface -> IO ()) -> IO ListenerToken 65 | setWlShellListener (WlrWlShell ptr) fun = 66 | let signal = #{ptr struct wlr_wl_shell, events.new_surface} ptr 67 | in addListener (WlListener $ fun . WlrWlShellSurface) signal 68 | 69 | 70 | foreign import ccall unsafe "wlr_wl_shell_surface_configure" c_surface_configure :: Ptr WlrWlShellSurface -> CInt -> Int32 -> Int32 -> IO () 71 | 72 | configureWlShellSurface :: WlrWlShellSurface -> Int32 -> Int32 -> IO () 73 | configureWlShellSurface (WlrWlShellSurface ptr) x y = c_surface_configure ptr 0 x y 74 | 75 | foreign import ccall unsafe "wlr_wl_shell_surface_surface_at" c_surface_at :: Ptr WlrWlShellSurface -> Double -> Double -> Ptr Double -> Ptr Double -> IO (Ptr WlrSurface) 76 | 77 | shellSurfaceAt :: WlrWlShellSurface -> Double -> Double -> IO (Maybe (Ptr WlrSurface, Double, Double)) 78 | shellSurfaceAt (WlrWlShellSurface ptr) x y = alloca $ \xptr -> alloca $ \yptr -> do 79 | ret <- c_surface_at ptr x y xptr yptr 80 | if ret == nullPtr 81 | then pure Nothing 82 | else Just .: (ret, ,) <$> peek xptr <*> peek yptr 83 | 84 | wlShellSurfaceGetSurface :: WlrWlShellSurface -> IO (Maybe (Ptr WlrSurface)) 85 | wlShellSurfaceGetSurface (WlrWlShellSurface ptr) = do 86 | ret <- #{peek struct wlr_wl_shell_surface, surface} ptr 87 | pure $ if ret == nullPtr 88 | then Nothing 89 | else Just ret 90 | 91 | getTitle :: WlrWlShellSurface -> IO (Maybe Text) 92 | getTitle (WlrWlShellSurface ptr) = textFromNull =<< #{peek struct wlr_wl_shell_surface, title} ptr 93 | 94 | getClass :: WlrWlShellSurface -> IO (Maybe Text) 95 | getClass (WlrWlShellSurface ptr) = textFromNull =<< #{peek struct wlr_wl_shell_surface, class} ptr 96 | 97 | 98 | data WlrWlSurfaceEvents = WlrWlSurfaceEvents 99 | { wlrWlSurfaceEvtDestroy :: Ptr (WlSignal WlrWlShellSurface) 100 | , wlrWlSurfaceEvtPopup :: Ptr (WlSignal WlrWlShellSurface) 101 | } 102 | 103 | getWlrWlSurfaceEvents :: WlrWlShellSurface -> WlrWlSurfaceEvents 104 | getWlrWlSurfaceEvents (WlrWlShellSurface ptr) = WlrWlSurfaceEvents 105 | { wlrWlSurfaceEvtDestroy = #{ptr struct wlr_wl_shell_surface, events.destroy} ptr 106 | , wlrWlSurfaceEvtPopup = #{ptr struct wlr_wl_shell_surface, events.new_popup} ptr 107 | } 108 | 109 | getWlShellPopups :: WlrWlShellSurface -> IO [WlrWlShellSurface] 110 | getWlShellPopups (WlrWlShellSurface ptr) = 111 | let list = #{ptr struct wlr_wl_shell_surface, popups} ptr 112 | in fmap WlrWlShellSurface <$> getListFromHead list #{offset struct wlr_wl_shell_surface, popup_link} 113 | 114 | isPopup :: WlrWlShellSurface -> IO Bool 115 | isPopup (WlrWlShellSurface ptr) = do 116 | val :: CInt <- #{peek struct wlr_wl_shell_surface, state} ptr 117 | pure $ val == #{const WLR_WL_SHELL_SURFACE_STATE_POPUP} 118 | 119 | 120 | getTransientPosition :: WlrWlShellSurface -> IO (Maybe (Int32, Int32)) 121 | getTransientPosition (WlrWlShellSurface ptr) = do 122 | state <- #{peek struct wlr_wl_shell_surface, transient_state} ptr 123 | if ptr == nullPtr 124 | then pure Nothing 125 | else Just <$> do 126 | x <- #{peek struct wlr_wl_shell_surface_transient_state, x} state 127 | y <- #{peek struct wlr_wl_shell_surface_transient_state, y} state 128 | pure (x, y) 129 | 130 | 131 | getClient :: WlrWlShellSurface -> IO Client 132 | getClient (WlrWlShellSurface ptr) = Client <$> #{peek struct wlr_wl_shell_surface, client} ptr 133 | -------------------------------------------------------------------------------- /src/Graphics/Wayland/WlRoots/XCursor.hsc: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | module Graphics.Wayland.WlRoots.XCursor 3 | ( WlrXCursorTheme 4 | , loadCursorTheme 5 | , destroyCursorTheme 6 | 7 | , WlrXCursor 8 | , getCursor 9 | 10 | , cursorFrame 11 | 12 | , getImages 13 | , WlrXCursorImage (..) 14 | ) 15 | where 16 | 17 | #include 18 | 19 | import Foreign.Storable (Storable(..)) 20 | import Foreign.C.String (CString, withCString) 21 | import Foreign.C.Types (CInt(..), CUInt(..)) 22 | import Foreign.Ptr (Ptr) 23 | import Data.Word (Word32) 24 | 25 | import Foreign.C.Error (throwErrnoIfNull) 26 | 27 | import Data.Composition ((.:)) 28 | 29 | data WlrXCursorTheme 30 | 31 | foreign import ccall "wlr_xcursor_theme_load" c_theme_load :: CString -> CInt -> IO (Ptr WlrXCursorTheme) 32 | 33 | loadCursorTheme :: String -> Word -> IO (Ptr WlrXCursorTheme) 34 | loadCursorTheme name size = withCString name $ \str -> 35 | throwErrnoIfNull "loadCursorTheme" $ c_theme_load str (fromIntegral size) 36 | 37 | foreign import ccall "wlr_xcursor_theme_destroy" c_theme_destroy :: Ptr WlrXCursorTheme -> IO () 38 | 39 | destroyCursorTheme :: Ptr WlrXCursorTheme -> IO () 40 | destroyCursorTheme = c_theme_destroy 41 | 42 | 43 | data WlrXCursor 44 | 45 | foreign import ccall "wlr_xcursor_theme_get_cursor" c_get_cursor :: Ptr WlrXCursorTheme -> CString -> IO (Ptr WlrXCursor) 46 | 47 | getCursor :: Ptr WlrXCursorTheme -> String -> IO (Ptr WlrXCursor) 48 | getCursor theme name = withCString name $ \str -> 49 | throwErrnoIfNull "getCursor" $ c_get_cursor theme str 50 | 51 | foreign import ccall "wlr_xcursor_frame" c_cursor_frame :: Ptr WlrXCursor -> Word32 -> IO CInt 52 | 53 | cursorFrame :: Ptr WlrXCursor -> Word32 -> IO Int 54 | cursorFrame = fmap fromIntegral .: c_cursor_frame 55 | 56 | getImages :: Ptr WlrXCursor -> IO [Ptr WlrXCursorImage] 57 | getImages xcursor = do 58 | count :: CUInt <- #{peek struct wlr_xcursor, image_count} xcursor 59 | ptr <- #{peek struct wlr_xcursor, images} xcursor 60 | mapM (peekElemOff ptr . fromIntegral) [0 .. count - 1] 61 | 62 | data WlrXCursorImage = WlrXCursorImage 63 | { xCursorImageWidth :: Word32 64 | , xCursorImageHeight :: Word32 65 | 66 | , xCursorImageHotspotX :: Word32 67 | , xCursorImageHotspotY :: Word32 68 | 69 | , xCursorImageDelay :: Word32 70 | 71 | , xCursorImageBuffer :: Ptr () 72 | } deriving (Eq, Show) 73 | 74 | instance Storable WlrXCursorImage where 75 | sizeOf _ = #{size struct wlr_xcursor_image} 76 | alignment _ = #{alignment struct wlr_xcursor_image} 77 | peek ptr = WlrXCursorImage 78 | <$> #{peek struct wlr_xcursor_image, width} ptr 79 | <*> #{peek struct wlr_xcursor_image, height} ptr 80 | <*> #{peek struct wlr_xcursor_image, hotspot_x} ptr 81 | <*> #{peek struct wlr_xcursor_image, hotspot_y} ptr 82 | <*> #{peek struct wlr_xcursor_image, delay} ptr 83 | <*> #{peek struct wlr_xcursor_image, buffer} ptr 84 | poke ptr image = do 85 | #{poke struct wlr_xcursor_image, width} ptr $ xCursorImageWidth image 86 | #{poke struct wlr_xcursor_image, height} ptr $ xCursorImageHeight image 87 | #{poke struct wlr_xcursor_image, hotspot_x} ptr $ xCursorImageHotspotX image 88 | #{poke struct wlr_xcursor_image, hotspot_y} ptr $ xCursorImageHotspotY image 89 | #{poke struct wlr_xcursor_image, delay} ptr $ xCursorImageDelay image 90 | #{poke struct wlr_xcursor_image, buffer} ptr $ xCursorImageBuffer image 91 | -------------------------------------------------------------------------------- /src/Graphics/Wayland/WlRoots/XCursorManager.hsc: -------------------------------------------------------------------------------- 1 | module Graphics.Wayland.WlRoots.XCursorManager 2 | ( WlrXCursorManager 3 | , xCursorManagerCreate 4 | , xCursorSetImage 5 | , xCursorLoad 6 | , xCursorManagerDestroy 7 | ) 8 | where 9 | 10 | #define WLR_USE_UNSTABLE 11 | #include 12 | 13 | import Data.Word (Word32) 14 | import Foreign.Ptr (Ptr) 15 | import Foreign.C.Types (CChar, CInt(..)) 16 | import Foreign.C.Error (throwErrnoIfNull, throwErrnoIfMinus1_) 17 | import Foreign.C.String (withCString) 18 | 19 | import Graphics.Wayland.WlRoots.Cursor (WlrCursor) 20 | 21 | data WlrXCursorManager 22 | 23 | foreign import ccall "wlr_xcursor_manager_create" c_manager_create :: Ptr CChar -> Word32 -> IO (Ptr WlrXCursorManager) 24 | 25 | xCursorManagerCreate :: String -> Word -> IO (Ptr WlrXCursorManager) 26 | xCursorManagerCreate name size = withCString name $ \str -> 27 | throwErrnoIfNull "xCursorManagerCreate" $ c_manager_create str (fromIntegral size) 28 | 29 | 30 | foreign import ccall "wlr_xcursor_manager_destroy" c_manager_destroy :: Ptr WlrXCursorManager -> IO () 31 | 32 | xCursorManagerDestroy :: Ptr WlrXCursorManager -> IO () 33 | xCursorManagerDestroy = c_manager_destroy 34 | 35 | foreign import ccall "wlr_xcursor_manager_set_cursor_image" c_set_cursor_image :: Ptr WlrXCursorManager -> Ptr CChar -> Ptr WlrCursor -> IO () 36 | 37 | xCursorSetImage :: Ptr WlrXCursorManager -> String -> Ptr WlrCursor -> IO () 38 | xCursorSetImage manager name cursor = withCString name $ \str -> 39 | c_set_cursor_image manager str cursor 40 | 41 | foreign import ccall "wlr_xcursor_manager_load" c_load :: Ptr WlrXCursorManager -> Float -> IO CInt 42 | 43 | xCursorLoad :: Ptr WlrXCursorManager -> Float -> IO () 44 | xCursorLoad manager scale = 45 | throwErrnoIfMinus1_ "xCursorLoad" $ c_load manager scale 46 | -------------------------------------------------------------------------------- /src/Graphics/Wayland/WlRoots/XWayland.hsc: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE EmptyDataDecls #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | module Graphics.Wayland.WlRoots.XWayland 4 | ( XWayland 5 | , xwaylandCreate 6 | , xwaylandDestroy 7 | , xwayBindNew 8 | , xwayReadEvent 9 | 10 | , X11Surface 11 | , xwaySurfaceGetSurface 12 | 13 | , xwayCloseSurface 14 | , getX11SurfaceDataPtr 15 | 16 | , ConfigureEvent (..) 17 | , MoveEvent (..) 18 | , ResizeEvent (..) 19 | , WlrX11SurfaceEvents (..) 20 | , getX11SurfaceEvents 21 | , activateX11Surface 22 | , configureX11Surface 23 | , getX11SurfacePosition 24 | , setX11SurfacePosition 25 | , getX11SurfaceGeometry 26 | 27 | , x11SurfaceOverrideRedirect 28 | , getTitle 29 | , getClass 30 | 31 | , getX11ParentSurfrace 32 | , getX11Children 33 | , setXWaylandSeat 34 | , isX11Mapped 35 | , getX11Pid 36 | 37 | , x11ORWantsFocus 38 | ) 39 | where 40 | 41 | #define WLR_USE_UNSTABLE 42 | #include 43 | 44 | 45 | import Data.Int (Int16) 46 | import Data.Text (Text) 47 | import Data.Word (Word16, Word32) 48 | import Data.Word (Word8) 49 | import Foreign.C.Error (throwErrnoIfNull) 50 | import Foreign.Ptr (Ptr, plusPtr, nullPtr) 51 | import Foreign.StablePtr (newStablePtr , castStablePtrToPtr) 52 | import Foreign.Storable (Storable(..)) 53 | import System.Posix.Types (ProcessID) 54 | 55 | import Graphics.Wayland.Server (DisplayServer (..)) 56 | import Graphics.Wayland.Signal 57 | import Graphics.Wayland.List 58 | import Graphics.Wayland.WlRoots.Seat (WlrSeat) 59 | import Graphics.Wayland.WlRoots.Box (Point(..), WlrBox(..)) 60 | import Graphics.Wayland.WlRoots.Compositor (WlrCompositor) 61 | import Graphics.Wayland.WlRoots.Surface (WlrSurface) 62 | import Utility (textFromNull) 63 | 64 | data XWayland 65 | 66 | foreign import ccall unsafe "wlr_xwayland_create" c_xwayland_create :: Ptr DisplayServer -> Ptr WlrCompositor -> Bool -> IO (Ptr XWayland) 67 | 68 | xwaylandCreate :: DisplayServer -> Ptr WlrCompositor -> Bool -> IO (Ptr XWayland) 69 | xwaylandCreate (DisplayServer ptr) comp lazy = 70 | throwErrnoIfNull "xwaylandCreate" $ c_xwayland_create ptr comp lazy 71 | 72 | foreign import ccall "wlr_xwayland_destroy" c_xwayland_destroy :: Ptr XWayland -> IO () 73 | 74 | xwaylandDestroy :: Ptr XWayland -> IO () 75 | xwaylandDestroy = c_xwayland_destroy 76 | 77 | xwayBindNew :: Ptr XWayland -> (Ptr X11Surface -> IO ()) -> IO () 78 | xwayBindNew shell handler = do 79 | let signal = #{ptr struct wlr_xwayland, events.new_surface} shell 80 | tok <- addListener (WlListener handler) signal 81 | sptr <- newStablePtr tok 82 | poke (#{ptr struct wlr_xwayland, data} shell) (castStablePtrToPtr sptr) 83 | 84 | xwayReadEvent :: Ptr XWayland -> Ptr (WlSignal XWayland) 85 | xwayReadEvent = #{ptr struct wlr_xwayland, events.ready} 86 | 87 | data X11Surface 88 | 89 | xwaySurfaceGetSurface :: Ptr X11Surface -> IO (Maybe (Ptr WlrSurface)) 90 | xwaySurfaceGetSurface ptr = do 91 | ret <- #{peek struct wlr_xwayland_surface, surface} ptr 92 | pure $ if ret == nullPtr 93 | then Nothing 94 | else Just ret 95 | 96 | foreign import ccall "wlr_xwayland_surface_close" c_close :: Ptr X11Surface -> IO () 97 | 98 | xwayCloseSurface :: Ptr X11Surface -> IO () 99 | xwayCloseSurface = c_close 100 | 101 | getX11SurfaceDataPtr :: Ptr X11Surface -> Ptr (Ptr a) 102 | getX11SurfaceDataPtr = #{ptr struct wlr_xwayland_surface, data} 103 | 104 | getX11ParentSurfrace :: Ptr X11Surface -> IO (Maybe (Ptr X11Surface)) 105 | getX11ParentSurfrace surf = do 106 | parent <- #{peek struct wlr_xwayland_surface, parent} surf 107 | if parent == nullPtr 108 | then pure Nothing 109 | else pure $ Just parent 110 | 111 | getX11Children :: Ptr X11Surface -> IO [Ptr X11Surface] 112 | getX11Children surf = 113 | let lHead = #{ptr struct wlr_xwayland_surface, children} surf 114 | in getListFromHead lHead #{offset struct wlr_xwayland_surface, parent_link} 115 | 116 | data ConfigureEvent = ConfigureEvent 117 | { configureEvtSurface :: Ptr X11Surface 118 | , configureEvtX :: Int16 119 | , configureEvtY :: Int16 120 | , configureEvtWidth :: Word16 121 | , configureEvtHeight :: Word16 122 | } 123 | 124 | instance Storable ConfigureEvent where 125 | sizeOf _ = #{size struct wlr_xwayland_surface_configure_event} 126 | alignment _ = #{alignment struct wlr_xwayland_surface_configure_event} 127 | peek ptr = ConfigureEvent 128 | <$> #{peek struct wlr_xwayland_surface_configure_event, surface} ptr 129 | <*> #{peek struct wlr_xwayland_surface_configure_event, x} ptr 130 | <*> #{peek struct wlr_xwayland_surface_configure_event, y} ptr 131 | <*> #{peek struct wlr_xwayland_surface_configure_event, width} ptr 132 | <*> #{peek struct wlr_xwayland_surface_configure_event, height} ptr 133 | poke ptr evt = do 134 | #{poke struct wlr_xwayland_surface_configure_event, surface} ptr $ configureEvtSurface evt 135 | #{poke struct wlr_xwayland_surface_configure_event, x} ptr $ configureEvtX evt 136 | #{poke struct wlr_xwayland_surface_configure_event, y} ptr $ configureEvtY evt 137 | #{poke struct wlr_xwayland_surface_configure_event, width} ptr $ configureEvtWidth evt 138 | #{poke struct wlr_xwayland_surface_configure_event, height} ptr $ configureEvtHeight evt 139 | 140 | data MoveEvent = MoveEvent 141 | { moveEvtSurface :: Ptr X11Surface 142 | } 143 | 144 | instance Storable MoveEvent where 145 | sizeOf _ = #{size struct wlr_xwayland_move_event} 146 | alignment _ = #{alignment struct wlr_xwayland_move_event} 147 | peek ptr = MoveEvent 148 | <$> #{peek struct wlr_xwayland_move_event, surface} ptr 149 | poke ptr evt = do 150 | #{poke struct wlr_xwayland_move_event, surface} ptr $ moveEvtSurface evt 151 | 152 | data ResizeEvent = ResizeEvent 153 | { resizeEvtSurface :: Ptr X11Surface 154 | , resizeEvtEdges :: Word32 155 | } 156 | 157 | instance Storable ResizeEvent where 158 | sizeOf _ = #{size struct wlr_xwayland_resize_event} 159 | alignment _ = #{alignment struct wlr_xwayland_resize_event} 160 | peek ptr = ResizeEvent 161 | <$> #{peek struct wlr_xwayland_resize_event, surface} ptr 162 | <*> #{peek struct wlr_xwayland_resize_event, edges} ptr 163 | poke ptr evt = do 164 | #{poke struct wlr_xwayland_resize_event, surface} ptr $ resizeEvtSurface evt 165 | #{poke struct wlr_xwayland_resize_event, edges} ptr $ resizeEvtEdges evt 166 | 167 | data WlrX11SurfaceEvents = WlrX11SurfaceEvents 168 | { x11SurfaceEvtDestroy :: Ptr (WlSignal X11Surface) 169 | , x11SurfaceEvtConfigure :: Ptr (WlSignal ConfigureEvent) 170 | , x11SurfaceEvtMove :: Ptr (WlSignal MoveEvent) 171 | , x11SurfaceEvtResize :: Ptr (WlSignal ResizeEvent) 172 | , x11SurfaceEvtFullscreen :: Ptr (WlSignal X11Surface) 173 | , x11SurfaceEvtMaximize :: Ptr (WlSignal X11Surface) 174 | 175 | , x11SurfaceEvtMap :: Ptr (WlSignal X11Surface) 176 | , x11SurfaceEvtUnmap :: Ptr (WlSignal X11Surface) 177 | , x11SurfaceEvtTitle :: Ptr (WlSignal X11Surface) 178 | , x11SurfaceEvtClass :: Ptr (WlSignal X11Surface) 179 | , x11SurfaceEvtParent :: Ptr (WlSignal X11Surface) 180 | , x11SurfaceEvtPid :: Ptr (WlSignal X11Surface) 181 | , x11SurfaceEvtType :: Ptr (WlSignal X11Surface) 182 | } 183 | 184 | 185 | getX11SurfaceEvents :: Ptr X11Surface -> WlrX11SurfaceEvents 186 | getX11SurfaceEvents ptr = WlrX11SurfaceEvents 187 | { x11SurfaceEvtDestroy = #{ptr struct wlr_xwayland_surface, events.destroy} ptr 188 | , x11SurfaceEvtConfigure = #{ptr struct wlr_xwayland_surface, events.request_configure} ptr 189 | , x11SurfaceEvtMove = #{ptr struct wlr_xwayland_surface, events.request_move} ptr 190 | , x11SurfaceEvtResize = #{ptr struct wlr_xwayland_surface, events.request_resize} ptr 191 | , x11SurfaceEvtFullscreen = #{ptr struct wlr_xwayland_surface, events.request_fullscreen} ptr 192 | , x11SurfaceEvtMaximize = #{ptr struct wlr_xwayland_surface, events.request_maximize} ptr 193 | 194 | , x11SurfaceEvtMap = #{ptr struct wlr_xwayland_surface, events.map} ptr 195 | , x11SurfaceEvtUnmap = #{ptr struct wlr_xwayland_surface, events.unmap} ptr 196 | , x11SurfaceEvtTitle = #{ptr struct wlr_xwayland_surface, events.set_title} ptr 197 | , x11SurfaceEvtClass = #{ptr struct wlr_xwayland_surface, events.set_class} ptr 198 | , x11SurfaceEvtParent = #{ptr struct wlr_xwayland_surface, events.set_parent} ptr 199 | , x11SurfaceEvtPid = #{ptr struct wlr_xwayland_surface, events.set_pid} ptr 200 | , x11SurfaceEvtType = #{ptr struct wlr_xwayland_surface, events.set_window_type} ptr 201 | } 202 | 203 | foreign import ccall "wlr_xwayland_surface_activate" c_activate :: Ptr X11Surface -> Bool -> IO () 204 | 205 | activateX11Surface :: Ptr X11Surface -> Bool -> IO () 206 | activateX11Surface = c_activate 207 | 208 | foreign import ccall "wlr_xwayland_surface_configure" c_configure :: Ptr X11Surface -> Int16 -> Int16 -> Word32 -> Word32 -> IO () 209 | 210 | configureX11Surface :: Ptr X11Surface -> Int16 -> Int16 -> Word32 -> Word32 -> IO () 211 | configureX11Surface surf x y width height = 212 | c_configure surf x y width height 213 | 214 | 215 | getX11SurfacePosition :: Ptr X11Surface -> IO (Point) 216 | getX11SurfacePosition surf = do 217 | x :: Int16 <- #{peek struct wlr_xwayland_surface, x} surf 218 | y :: Int16 <- #{peek struct wlr_xwayland_surface, y} surf 219 | pure $ Point (fromIntegral x) (fromIntegral y) 220 | 221 | 222 | setX11SurfacePosition :: Ptr X11Surface -> Point -> IO () 223 | setX11SurfacePosition surf (Point x y)= do 224 | #{poke struct wlr_xwayland_surface, x} surf (fromIntegral x :: Word16) 225 | #{poke struct wlr_xwayland_surface, y} surf (fromIntegral y :: Word16) 226 | 227 | getX11SurfaceGeometry :: Ptr X11Surface -> IO WlrBox 228 | getX11SurfaceGeometry surf = do 229 | (Point x y) <- getX11SurfacePosition surf 230 | width :: Word16 <- #{peek struct wlr_xwayland_surface, width} surf 231 | height :: Word16 <- #{peek struct wlr_xwayland_surface, height} surf 232 | pure $ WlrBox x y (fromIntegral width) (fromIntegral height) 233 | 234 | 235 | x11SurfaceOverrideRedirect :: Ptr X11Surface -> IO Bool 236 | x11SurfaceOverrideRedirect ptr = do 237 | val :: Word8 <- #{peek struct wlr_xwayland_surface, override_redirect} ptr 238 | pure $ val /= 0 239 | 240 | getTitle :: Ptr X11Surface -> IO (Maybe Text) 241 | getTitle ptr = textFromNull =<< #{peek struct wlr_xwayland_surface, title} ptr 242 | 243 | getClass :: Ptr X11Surface -> IO (Maybe Text) 244 | getClass ptr = textFromNull =<< #{peek struct wlr_xwayland_surface, class} ptr 245 | 246 | foreign import ccall "wlr_xwayland_set_seat" c_set_seat :: Ptr XWayland -> Ptr WlrSeat -> IO () 247 | 248 | setXWaylandSeat :: Ptr XWayland -> Ptr WlrSeat -> IO () 249 | setXWaylandSeat = c_set_seat 250 | 251 | isX11Mapped :: Ptr X11Surface -> IO Bool 252 | isX11Mapped ptr = do 253 | val :: Word8 <- #{peek struct wlr_xwayland_surface, mapped} ptr 254 | pure $ val /= 0 255 | 256 | getX11Pid :: Ptr X11Surface -> IO ProcessID 257 | getX11Pid = #{peek struct wlr_xwayland_surface, pid} 258 | 259 | foreign import ccall "wlr_xwayland_or_surface_wants_focus" c_wants_focus :: Ptr X11Surface -> IO Word8 260 | 261 | x11ORWantsFocus :: Ptr X11Surface -> IO Bool 262 | x11ORWantsFocus = fmap (/= 0) . c_wants_focus 263 | -------------------------------------------------------------------------------- /src/Graphics/Wayland/WlRoots/XdgShell.hsc: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | module Graphics.Wayland.WlRoots.XdgShell 3 | ( WlrXdgShell 4 | , xdgShellCreate 5 | , xdgShellDestroy 6 | 7 | , WlrXdgSurface 8 | , xdgSurfaceGetSurface 9 | , getXdgToplevel 10 | 11 | , WlrXdgToplevel 12 | , WlrXdgToplevelEvents 13 | , getXdgToplevelEvents 14 | 15 | , MoveEvent (..) 16 | , ResizeEvent (..) 17 | , MenuEvent (..) 18 | , FullscreenEvent (..) 19 | , WlrXdgSurfaceEvents (..) 20 | , getXdgSurfaceEvents 21 | , getXdgSurfaceDataPtr 22 | 23 | , sendClose 24 | , setSize 25 | , getGeometry 26 | , setActivated 27 | , setMaximized 28 | 29 | , getPopups 30 | , isXdgPopup 31 | , isConfigured 32 | 33 | , getPopupGeometry 34 | , xdgSurfaceAt 35 | 36 | , getTitle 37 | , getAppId 38 | 39 | , WlrXdgPopup 40 | , xdgPopupGetBase 41 | , xdgGetPopupSurfaces 42 | 43 | , unconstrainPopup 44 | , getConfigureSerial 45 | ) 46 | where 47 | 48 | #define WLR_USE_UNSTABLE 49 | #include 50 | 51 | import Data.Text (Text) 52 | import Data.Word (Word32) 53 | import Foreign.Storable (Storable(..)) 54 | import Foreign.Ptr (Ptr, plusPtr, nullPtr) 55 | import Foreign.C.Types (CInt) 56 | import Foreign.C.Error (throwErrnoIfNull) 57 | import Foreign.Marshal.Alloc (alloca) 58 | import Foreign.Marshal.Utils (with) 59 | import Foreign.StablePtr 60 | ( newStablePtr 61 | , castStablePtrToPtr 62 | ) 63 | 64 | import Graphics.Wayland.Server (DisplayServer(..)) 65 | import Graphics.Wayland.WlRoots.Output (WlrOutput) 66 | import Graphics.Wayland.WlRoots.Surface (WlrSurface) 67 | import Graphics.Wayland.WlRoots.Box (WlrBox) 68 | import Graphics.Wayland.WlRoots.Seat (WlrSeatClient) 69 | import Graphics.Wayland.List (getListFromHead) 70 | 71 | import Graphics.Wayland.Signal 72 | import Utility (textFromNull) 73 | import Control.Monad (when) 74 | 75 | data WlrXdgShell 76 | 77 | foreign import ccall unsafe "wlr_xdg_shell_create" c_shell_create :: Ptr DisplayServer -> IO (Ptr WlrXdgShell) 78 | 79 | xdgShellCreate :: (Ptr WlrXdgSurface -> IO ()) -> DisplayServer -> IO (Ptr WlrXdgShell) 80 | xdgShellCreate new (DisplayServer ptr) = do 81 | shell <- throwErrnoIfNull "shellCreate" $ c_shell_create ptr 82 | 83 | let signal = #{ptr struct wlr_xdg_shell, events.new_surface} shell 84 | handler <- addListener (WlListener new) signal 85 | sptr <- newStablePtr handler 86 | poke (#{ptr struct wlr_xdg_shell, data} shell) (castStablePtrToPtr sptr) 87 | 88 | pure shell 89 | 90 | foreign import ccall unsafe "wlr_xdg_shell_destroy" c_shell_destroy :: Ptr WlrXdgShell -> IO () 91 | 92 | xdgShellDestroy :: Ptr WlrXdgShell -> IO () 93 | xdgShellDestroy = c_shell_destroy 94 | 95 | data WlrXdgSurface 96 | data WlrXdgToplevel 97 | 98 | isConfigured :: Ptr WlrXdgSurface -> IO Bool 99 | isConfigured = #{peek struct wlr_xdg_surface, configured} 100 | 101 | isXdgPopup :: Ptr WlrXdgSurface -> IO Bool 102 | isXdgPopup surf = do 103 | role :: CInt <- #{peek struct wlr_xdg_surface, role} surf 104 | pure (role == #{const WLR_XDG_SURFACE_ROLE_POPUP}) 105 | 106 | xdgSurfaceGetSurface :: Ptr WlrXdgSurface -> IO (Maybe (Ptr WlrSurface)) 107 | xdgSurfaceGetSurface ptr = do 108 | ret <- #{peek struct wlr_xdg_surface, surface} ptr 109 | pure $ if ret == nullPtr 110 | then Nothing 111 | else Just ret 112 | 113 | data MoveEvent = MoveEvent 114 | { moveEvtSurface :: Ptr WlrXdgSurface 115 | , moveEvtSeat :: Ptr WlrSeatClient 116 | , moveEvtSerial :: Word32 117 | } 118 | 119 | instance Storable MoveEvent where 120 | sizeOf _ = #{size struct wlr_xdg_toplevel_move_event} 121 | alignment _ = #{alignment struct wlr_xdg_toplevel_move_event} 122 | peek ptr = MoveEvent 123 | <$> #{peek struct wlr_xdg_toplevel_move_event, surface} ptr 124 | <*> #{peek struct wlr_xdg_toplevel_move_event, seat} ptr 125 | <*> #{peek struct wlr_xdg_toplevel_move_event, serial} ptr 126 | poke ptr evt = do 127 | #{poke struct wlr_xdg_toplevel_move_event, surface} ptr $ moveEvtSurface evt 128 | #{poke struct wlr_xdg_toplevel_move_event, seat} ptr $ moveEvtSeat evt 129 | #{poke struct wlr_xdg_toplevel_move_event, serial} ptr $ moveEvtSerial evt 130 | 131 | 132 | data ResizeEvent = ResizeEvent 133 | { resizeEvtSurface :: Ptr WlrXdgSurface 134 | , resizeEvtSeat :: Ptr WlrSeatClient 135 | , resizeEvtSerial :: Word32 136 | , resizeEvtEdges :: Word32 -- TODO: Make this a [Edge] 137 | } 138 | 139 | instance Storable ResizeEvent where 140 | sizeOf _ = #{size struct wlr_xdg_toplevel_resize_event} 141 | alignment _ = #{alignment struct wlr_xdg_toplevel_resize_event} 142 | peek ptr = ResizeEvent 143 | <$> #{peek struct wlr_xdg_toplevel_resize_event, surface} ptr 144 | <*> #{peek struct wlr_xdg_toplevel_resize_event, seat} ptr 145 | <*> #{peek struct wlr_xdg_toplevel_resize_event, serial} ptr 146 | <*> #{peek struct wlr_xdg_toplevel_resize_event, edges} ptr 147 | poke ptr evt = do 148 | #{poke struct wlr_xdg_toplevel_resize_event, surface} ptr $ resizeEvtSurface evt 149 | #{poke struct wlr_xdg_toplevel_resize_event, seat} ptr $ resizeEvtSeat evt 150 | #{poke struct wlr_xdg_toplevel_resize_event, serial} ptr $ resizeEvtSerial evt 151 | #{poke struct wlr_xdg_toplevel_resize_event, edges} ptr $ resizeEvtEdges evt 152 | 153 | data MenuEvent = MenuEvent 154 | { menuEvtSurface :: Ptr WlrXdgSurface 155 | , menuEvtSeat :: Ptr WlrSeatClient 156 | , menuEvtSerial :: Word32 157 | , menuEvtX :: Word32 158 | , menuEvtY :: Word32 159 | } 160 | 161 | instance Storable MenuEvent where 162 | sizeOf _ = #{size struct wlr_xdg_toplevel_show_window_menu_event} 163 | alignment _ = #{alignment struct wlr_xdg_toplevel_show_window_menu_event} 164 | peek ptr = MenuEvent 165 | <$> #{peek struct wlr_xdg_toplevel_show_window_menu_event, surface} ptr 166 | <*> #{peek struct wlr_xdg_toplevel_show_window_menu_event, seat} ptr 167 | <*> #{peek struct wlr_xdg_toplevel_show_window_menu_event, serial} ptr 168 | <*> #{peek struct wlr_xdg_toplevel_show_window_menu_event, x} ptr 169 | <*> #{peek struct wlr_xdg_toplevel_show_window_menu_event, y} ptr 170 | poke ptr evt = do 171 | #{poke struct wlr_xdg_toplevel_show_window_menu_event, surface} ptr $ menuEvtSurface evt 172 | #{poke struct wlr_xdg_toplevel_show_window_menu_event, seat} ptr $ menuEvtSeat evt 173 | #{poke struct wlr_xdg_toplevel_show_window_menu_event, serial} ptr $ menuEvtSerial evt 174 | #{poke struct wlr_xdg_toplevel_show_window_menu_event, x} ptr $ menuEvtX evt 175 | #{poke struct wlr_xdg_toplevel_show_window_menu_event, y} ptr $ menuEvtY evt 176 | 177 | data FullscreenEvent = FullscreenEvent 178 | { fullscreenEvtSurface :: Ptr WlrXdgSurface 179 | , fullscreenEvtFull :: Bool 180 | , fullscreenEvtOutput :: Ptr WlrOutput 181 | } 182 | 183 | instance Storable FullscreenEvent where 184 | sizeOf _ = #{size struct wlr_xdg_toplevel_set_fullscreen_event} 185 | alignment _ = #{alignment struct wlr_xdg_toplevel_set_fullscreen_event} 186 | peek ptr = FullscreenEvent 187 | <$> #{peek struct wlr_xdg_toplevel_set_fullscreen_event, surface} ptr 188 | <*> #{peek struct wlr_xdg_toplevel_set_fullscreen_event, fullscreen} ptr 189 | <*> #{peek struct wlr_xdg_toplevel_set_fullscreen_event, output} ptr 190 | poke ptr evt = do 191 | #{poke struct wlr_xdg_toplevel_set_fullscreen_event, surface} ptr $ fullscreenEvtSurface evt 192 | #{poke struct wlr_xdg_toplevel_set_fullscreen_event, fullscreen} ptr $ fullscreenEvtFull evt 193 | #{poke struct wlr_xdg_toplevel_set_fullscreen_event, output} ptr $ fullscreenEvtOutput evt 194 | 195 | data WlrXdgSurfaceEvents = WlrXdgSurfaceEvents 196 | { xdgSurfaceEvtDestroy :: Ptr (WlSignal WlrXdgSurface) 197 | , xdgSurfaceEvtTimeout :: Ptr (WlSignal WlrXdgSurface) 198 | , xdgSurfaceEvtPopup :: Ptr (WlSignal WlrXdgPopup) 199 | , xdgSurfaceEvtMap :: Ptr (WlSignal WlrXdgSurface) 200 | , xdgSurfaceEvtUnmap :: Ptr (WlSignal WlrXdgSurface) 201 | } 202 | 203 | getXdgSurfaceEvents :: Ptr WlrXdgSurface -> WlrXdgSurfaceEvents 204 | getXdgSurfaceEvents ptr = WlrXdgSurfaceEvents 205 | { xdgSurfaceEvtDestroy = #{ptr struct wlr_xdg_surface, events.destroy} ptr 206 | , xdgSurfaceEvtTimeout = #{ptr struct wlr_xdg_surface, events.ping_timeout} ptr 207 | , xdgSurfaceEvtPopup = #{ptr struct wlr_xdg_surface, events.new_popup} ptr 208 | , xdgSurfaceEvtMap = #{ptr struct wlr_xdg_surface, events.map} ptr 209 | , xdgSurfaceEvtUnmap = #{ptr struct wlr_xdg_surface, events.unmap} ptr 210 | } 211 | 212 | data WlrXdgToplevelEvents = WlrXdgToplevelEvents 213 | { xdgToplevelEvtMaximize :: Ptr (WlSignal WlrXdgSurface) 214 | , xdgToplevelEvtFullscreen :: Ptr (WlSignal FullscreenEvent) 215 | , xdgToplevelEvtMinimize :: Ptr (WlSignal WlrXdgSurface) 216 | 217 | , xdgToplevelEvtMove :: Ptr (WlSignal MoveEvent) 218 | , xdgToplevelEvtResize :: Ptr (WlSignal ResizeEvent) 219 | , xdgToplevelEvtMenu :: Ptr (WlSignal MenuEvent) 220 | } 221 | 222 | getXdgToplevelEvents :: Ptr WlrXdgToplevel -> WlrXdgToplevelEvents 223 | getXdgToplevelEvents ptr = WlrXdgToplevelEvents 224 | { xdgToplevelEvtMaximize = #{ptr struct wlr_xdg_toplevel, events.request_maximize} ptr 225 | , xdgToplevelEvtFullscreen = #{ptr struct wlr_xdg_toplevel, events.request_fullscreen} ptr 226 | , xdgToplevelEvtMinimize = #{ptr struct wlr_xdg_toplevel, events.request_minimize} ptr 227 | 228 | , xdgToplevelEvtMove = #{ptr struct wlr_xdg_toplevel, events.request_move} ptr 229 | , xdgToplevelEvtResize = #{ptr struct wlr_xdg_toplevel, events.request_resize} ptr 230 | , xdgToplevelEvtMenu = #{ptr struct wlr_xdg_toplevel, events.request_show_window_menu} ptr 231 | } 232 | 233 | getXdgToplevel :: Ptr WlrXdgSurface -> IO (Maybe (Ptr WlrXdgToplevel)) 234 | getXdgToplevel ptr = do 235 | ret <- #{peek struct wlr_xdg_surface, toplevel} ptr 236 | role :: CInt <- #{peek struct wlr_xdg_surface, role} ptr 237 | pure $ if role /= #{const WLR_XDG_SURFACE_ROLE_TOPLEVEL} || ret == nullPtr 238 | then Nothing 239 | else Just ret 240 | 241 | getXdgSurfaceDataPtr :: Ptr WlrXdgSurface -> Ptr (Ptr ()) 242 | getXdgSurfaceDataPtr = #{ptr struct wlr_xdg_surface, data} 243 | 244 | foreign import ccall "wlr_xdg_surface_surface_at" c_surface_at :: Ptr WlrXdgSurface -> Double -> Double -> Ptr Double -> Ptr Double -> IO (Ptr WlrSurface) 245 | 246 | xdgSurfaceAt :: Ptr WlrXdgSurface -> Double -> Double -> IO (Maybe (Ptr WlrSurface, Double, Double)) 247 | xdgSurfaceAt surf x y = alloca $ \xptr -> alloca $ \yptr -> do 248 | popup <- c_surface_at surf x y xptr yptr 249 | if popup == nullPtr 250 | then pure Nothing 251 | else do 252 | newx <- peek xptr 253 | newy <- peek yptr 254 | pure $ Just (popup, newx, newy) 255 | 256 | 257 | foreign import ccall "wlr_xdg_toplevel_send_close" c_close :: Ptr WlrXdgSurface -> IO () 258 | 259 | sendClose :: Ptr WlrXdgSurface -> IO () 260 | sendClose surf = do 261 | role :: CInt <- #{peek struct wlr_xdg_surface, role} surf 262 | case role of 263 | #{const WLR_XDG_SURFACE_ROLE_TOPLEVEL} -> c_close surf 264 | _ -> pure () 265 | 266 | foreign import ccall "wlr_xdg_surface_get_geometry" c_get_geometry :: Ptr WlrXdgSurface -> Ptr WlrBox -> IO () 267 | 268 | getGeometry :: Ptr WlrXdgSurface -> IO WlrBox 269 | getGeometry ptr = alloca $ \boxPtr -> do 270 | c_get_geometry ptr boxPtr 271 | peek boxPtr 272 | 273 | foreign import ccall "wlr_xdg_toplevel_set_size" c_set_size :: Ptr WlrXdgSurface -> Word32 -> Word32 -> IO Word32 274 | 275 | setSize :: Ptr WlrXdgSurface -> Word32 -> Word32 -> IO Word32 276 | setSize surf width height = do 277 | role :: CInt <- #{peek struct wlr_xdg_surface, role} surf 278 | case role of 279 | #{const WLR_XDG_SURFACE_ROLE_TOPLEVEL} -> c_set_size surf width height 280 | _ -> pure 0 281 | 282 | 283 | 284 | foreign import ccall "wlr_xdg_toplevel_set_activated" c_activate :: Ptr WlrXdgSurface -> Bool -> IO () 285 | 286 | setActivated :: Ptr WlrXdgSurface -> Bool -> IO () 287 | setActivated surf active = do 288 | role :: CInt <- #{peek struct wlr_xdg_surface, role} surf 289 | when 290 | (role == #{const WLR_XDG_SURFACE_ROLE_TOPLEVEL}) 291 | (c_activate surf active) 292 | 293 | 294 | 295 | foreign import ccall "wlr_xdg_toplevel_set_maximized" c_maximize :: Ptr WlrXdgSurface -> Bool -> IO () 296 | 297 | setMaximized :: Ptr WlrXdgSurface -> Bool -> IO () 298 | setMaximized surf maximized = do 299 | role :: CInt <- #{peek struct wlr_xdg_surface, role} surf 300 | when 301 | (role == #{const WLR_XDG_SURFACE_ROLE_TOPLEVEL}) 302 | (c_maximize surf maximized) 303 | 304 | 305 | getPopups :: Ptr WlrXdgSurface -> IO [Ptr WlrXdgPopup] 306 | getPopups surf = do 307 | let list = #{ptr struct wlr_xdg_surface, popups} surf 308 | getListFromHead list #{offset struct wlr_xdg_popup, link} 309 | 310 | xdgPopupGetBase :: Ptr WlrXdgPopup -> IO (Ptr WlrXdgSurface) 311 | xdgPopupGetBase = #{peek struct wlr_xdg_popup, base} 312 | 313 | xdgGetPopupSurfaces :: Ptr WlrXdgSurface -> IO [Ptr WlrXdgSurface] 314 | xdgGetPopupSurfaces surf = 315 | mapM xdgPopupGetBase =<< getPopups surf 316 | 317 | data WlrXdgPopup 318 | 319 | getPopupState :: Ptr WlrXdgSurface -> IO (Maybe (Ptr WlrXdgPopup)) 320 | getPopupState surf = do 321 | ret <- #{peek struct wlr_xdg_surface, popup} surf 322 | pure $ if ret /= nullPtr 323 | then Just ret 324 | else Nothing 325 | 326 | getPopupGeometry :: Ptr WlrXdgSurface -> IO (Maybe WlrBox) 327 | getPopupGeometry surf = traverse #{peek struct wlr_xdg_popup, geometry} =<< getPopupState surf 328 | 329 | 330 | getTitle :: Ptr WlrXdgToplevel -> IO (Maybe Text) 331 | getTitle ptr = textFromNull =<< #{peek struct wlr_xdg_toplevel, title} ptr 332 | 333 | getAppId :: Ptr WlrXdgToplevel -> IO (Maybe Text) 334 | getAppId ptr = textFromNull =<< #{peek struct wlr_xdg_toplevel, app_id} ptr 335 | 336 | foreign import ccall unsafe "wlr_xdg_popup_unconstrain_from_box" c_popup_unconstrain_from_box :: Ptr WlrXdgPopup -> Ptr WlrBox -> IO () 337 | 338 | -- | Box in popups root toplevel coordinates 339 | unconstrainPopup :: Ptr WlrXdgPopup -> WlrBox -> IO () 340 | unconstrainPopup pop box = with box $ c_popup_unconstrain_from_box pop 341 | 342 | getConfigureSerial :: Ptr WlrXdgSurface -> IO Word32 343 | getConfigureSerial = #{peek struct wlr_xdg_surface, configure_serial} 344 | 345 | -------------------------------------------------------------------------------- /src/Utility.hs: -------------------------------------------------------------------------------- 1 | module Utility 2 | where 3 | 4 | import Data.ByteString.Unsafe (unsafePackCString) 5 | import Data.Text (Text) 6 | import Foreign.C.Types (CChar) 7 | import Foreign.Ptr (Ptr, nullPtr) 8 | 9 | import qualified Data.Text.Encoding as E 10 | 11 | 12 | textFromPtr :: Ptr CChar -> IO Text 13 | textFromPtr = fmap E.decodeUtf8 . unsafePackCString 14 | 15 | textFromNull :: Ptr CChar -> IO (Maybe Text) 16 | textFromNull ptr = if ptr == nullPtr 17 | then pure Nothing 18 | else Just <$> textFromPtr ptr 19 | --------------------------------------------------------------------------------