├── .build.yml ├── .envrc ├── .gitignore ├── .license_template ├── .travis.yml ├── ChangeLog.md ├── LICENSE ├── README.md ├── Setup.hs ├── assets ├── LICENSE ├── logo-heavy.svg └── logo-light.svg ├── bin └── Main.hs ├── cabal.project ├── cbits └── background.c ├── default.nix ├── hayland ├── .gitignore ├── Graphics │ ├── Wayland.hs │ └── Wayland │ │ ├── Client.hs │ │ ├── Internal.hs │ │ ├── Internal │ │ ├── Client.chs │ │ ├── Cursor.chs │ │ ├── EGL.chs │ │ ├── Server.chs │ │ ├── ServerClientState.chs │ │ ├── SpliceClient.hs │ │ ├── SpliceClientInternal.hs │ │ ├── SpliceClientTypes.hs │ │ ├── SpliceServer.hs │ │ ├── SpliceServerInternal.hs │ │ ├── SpliceServerTypes.hs │ │ ├── Util.chs │ │ └── Version.chs │ │ ├── Scanner.chs │ │ ├── Scanner │ │ ├── Marshaller.chs │ │ ├── Names.hs │ │ ├── Protocol.hs │ │ └── Types.chs │ │ └── Server.hs ├── LICENSE ├── NOTES.md ├── README.md ├── Setup.hs ├── default.nix ├── hayland.cabal ├── hayland.nix ├── shell.nix └── tests │ ├── enums.hs │ ├── listglobals.hs │ └── test.hs ├── hsroots-new ├── LICENSE ├── WlRoots │ ├── Backend.hs │ └── Internal │ │ └── Generate.hs ├── hsroots.cabal └── hsroots.nix ├── hsroots ├── .gitignore ├── ChangeLog.md ├── LICENSE ├── README.md ├── Setup.hs ├── cbits │ ├── cat.c │ ├── cat.h │ └── signal.c ├── hsroots.cabal ├── hsroots.nix └── 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 │ │ ├── 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 │ │ ├── Seat.hsc │ │ ├── ServerDecoration.hsc │ │ ├── Surface.hsc │ │ ├── SurfaceLayers.hsc │ │ ├── Tabletv2.hsc │ │ ├── Util.hsc │ │ ├── Util │ │ └── Region.hsc │ │ ├── XCursor.hsc │ │ ├── XCursorManager.hsc │ │ ├── XWayland.hsc │ │ ├── XdgShell.hsc │ │ └── XdgShellv6.hsc │ └── Utility.hs ├── license_helper.sh ├── manifest ├── overlay.nix ├── protocols └── background.xml ├── shell.nix ├── sources.nix ├── src ├── Config.hs ├── Config │ ├── Box.hs │ ├── Input.hs │ ├── Logger.hs │ └── Output.hs ├── Fuse │ ├── Common.hs │ ├── Extensible.hs │ ├── Handler.hs │ ├── Inputs.hs │ ├── Main.hs │ ├── Outputs.hs │ ├── Rts.hs │ ├── Shells.hs │ └── Workspaces.hs ├── Waymonad.hs └── Waymonad │ ├── Actions │ ├── Spawn.hs │ ├── Spawn │ │ └── X11.hs │ └── Startup │ │ ├── Environment.hs │ │ └── Generic.hs │ ├── Extensible.hs │ ├── GlobalFilter.hs │ ├── Hooks │ ├── EnterLeave.hs │ ├── FocusFollowPointer.hs │ ├── KeyboardFocus.hs │ ├── OutputAdd.hs │ ├── ScaleHook.hs │ └── SeatMapping.hs │ ├── IPC.hs │ ├── IdleDPMS.hs │ ├── IdleManager.hs │ ├── Input.hs │ ├── Input.hs-boot │ ├── Input │ ├── Cursor.hs │ ├── Cursor.hs-boot │ ├── Cursor │ │ ├── Bindings.hs │ │ └── Type.hs │ ├── Keyboard.hs │ ├── Libinput.hs │ ├── Seat.hs │ ├── Seat.hs-boot │ ├── Tablet.hs │ ├── Tablet │ │ └── Types.hs │ └── TabletPad.hs │ ├── Layout.hs │ ├── Layout │ ├── AvoidStruts.hs │ ├── Choose.hs │ ├── Full.hs │ ├── Mirror.hs │ ├── Quadrant.hs │ ├── Ratio.hs │ ├── SmartBorders.hs │ ├── Spiral.hs │ ├── Tall.hs │ ├── ToggleFull.hs │ ├── TwoPane.hs │ └── Vertical.hs │ ├── Log │ └── Domain.hs │ ├── Main.hs │ ├── Managehook.hs │ ├── Navigation2D.hs │ ├── Output.hs │ ├── Output │ ├── Core.hs │ └── Render.hs │ ├── Protocols │ ├── Background.hs │ ├── DMAExport.hs │ ├── DataControl.hs │ ├── IdleInhibit.hs │ ├── InputInhibit.hs │ ├── InputInhibit.hs-boot │ ├── LinuxDMABuf.hs │ └── PrimarySelection.hs │ ├── Shells.hs │ ├── Shells │ ├── Layers.hs │ ├── Pseudo │ │ └── Multi.hs │ ├── XWayland.hs │ ├── XdgShell.hs │ └── XdgShellv6.hs │ ├── Start.hs │ ├── Systemd.hsc │ ├── Tabletv2.hs │ ├── Types.hs │ ├── Types │ ├── Core.hs │ └── Logger.hs │ ├── Utility.hs │ ├── Utility │ ├── Base.hs │ ├── Current.hs │ ├── Extensible.hs │ ├── Floating.hs │ ├── Focus.hs │ ├── HaskellSignal.hs │ ├── LayerCache.hs │ ├── Layout.hs │ ├── Log.hs │ ├── Mapping.hs │ ├── Pointer.hs │ ├── SSD.hs │ ├── Signal.hs │ ├── Timing.hsc │ ├── View.hs │ └── ViewSet.hs │ ├── View.hs │ ├── ViewSet.hs │ └── ViewSet │ ├── HLWM.hs │ ├── Utility.hs │ └── XMonad.hs ├── waymonad-scanner ├── .gitignore ├── ChangeLog.md ├── LICENSE ├── Setup.hs ├── src │ ├── Graphics │ │ └── Wayland │ │ │ ├── Scanner.hs │ │ │ └── Scanner │ │ │ ├── Dispatcher.hsc │ │ │ ├── Marshal.hsc │ │ │ ├── Types.hs │ │ │ ├── WLS.hs │ │ │ └── XML.hs │ └── Utility.hs ├── waymonad-scanner.cabal └── waymonad-scanner.nix ├── waymonad.cabal └── waymonad.nix /.build.yml: -------------------------------------------------------------------------------- 1 | image: debian/buster 2 | packages: 3 | - build-essential 4 | - git 5 | - python3-pip 6 | - pkg-config 7 | - libwayland-dev 8 | - libegl1-mesa-dev 9 | - wayland-protocols 10 | - libgles2-mesa-dev 11 | - libgbm-dev 12 | - libinput-dev 13 | - libxkbcommon-dev 14 | - libpixman-1-dev 15 | - libxcb-composite0-dev 16 | - libxcb-image0-dev 17 | - cabal-install 18 | - ghc 19 | - happy 20 | - alex 21 | - c2hs 22 | - libfuse-dev 23 | 24 | sources: 25 | - https://github.com/ongy/waymonad 26 | tasks: 27 | - setup: | 28 | pip3 install meson ninja 29 | git clone https://github.com/swaywm/wlroots 30 | ( 31 | cd wlroots 32 | meson build --prefix=/usr/ 33 | ninja -C build install 34 | ) 35 | - build: | 36 | cd waymonad 37 | git submodule update --recursive --init 38 | touch hsroots/haskell-xkbcommon/dist 39 | cabal update 40 | cabal new-build 41 | -------------------------------------------------------------------------------- /.envrc: -------------------------------------------------------------------------------- 1 | use nix 2 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | dist-* 3 | cabal-dev 4 | *.o 5 | *.hi 6 | *.chi 7 | *.chs.h 8 | *.dyn_o 9 | *.dyn_hi 10 | .hpc 11 | .hsenv 12 | .cabal-sandbox/ 13 | cabal.sandbox.config 14 | *.prof 15 | *.aux 16 | *.hp 17 | *.eventlog 18 | .stack-work/ 19 | cabal.project.local 20 | .HTF/ 21 | *.swp 22 | .ghc.environment* 23 | .direnv/ 24 | /core 25 | -------------------------------------------------------------------------------- /.license_template: -------------------------------------------------------------------------------- 1 | {- 2 | {{PROJECT}} 3 | Copyright (C) {{YEAR}} {{NAME}} 4 | 5 | This library is free software; you can redistribute it and/or 6 | modify it under the terms of the GNU Lesser General Public 7 | License as published by the Free Software Foundation; either 8 | version 2.1 of the License, or (at your option) any later version. 9 | 10 | This library is distributed in the hope that it will be useful, 11 | but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 13 | Lesser General Public License for more details. 14 | 15 | You should have received a copy of the GNU Lesser General Public 16 | License along with this library; if not, write to the Free Software 17 | Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA 18 | 19 | {{REACH}} 20 | -} 21 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: nix 2 | script: 3 | - nix-env -iA cachix -f https://cachix.org/api/v1/install 4 | - cachix use waymonad 5 | - nix-build -j2 6 | -------------------------------------------------------------------------------- /ChangeLog.md: -------------------------------------------------------------------------------- 1 | # Revision history for waymonad 2 | 3 | ## 0.0.1.0 -- YYYY-mm-dd 4 | 5 | * First version. Released on an unsuspecting world. 6 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | ## About 2 | 3 | Waymonad is a Wayland compositor made with wlroots that aims to feel like [xmonad](https://github.com/xmonad/xmonad). 4 | 5 | This is a fork of Waymonad that will hopefully be merged back into https://github.com/waymonad/waymonad eventually. 6 | 7 | ## Communication channels 8 | 9 | Join us in [#waymonad:matrix.org](https://matrix.to/#/#waymonad:matrix.org)! 10 | 11 | ## Running it 12 | 13 | You must first install [Nix](https://nixos.org/download.html), 14 | and after that you can run `nix-shell --pure` in the root of the repository. 15 | This will give you an environment with GHC, Cabal, etc. 16 | 17 | Now you can simply run `cabal run` which hopefully will launch Waymonad. 18 | You can launch a program inside Waymonad by simply setting WAYLAND_DISPLAY 19 | before launching a program, e.g. `env WAYLAND_DISPLAY=wayland-1 pavucontrol`. 20 | If you're not already running a Wayland compositor, it will likely be `wayland-0` instead. 21 | 22 | ## Status 23 | 24 | - It runs on wlroots 0.14.0 (latest as of now) 25 | - It is not documented nor user friendly 26 | - It crashes occasionally due to pointer handling bugs 27 | - It needs some internal redesigning (see Contributing) 28 | 29 | ## Contributing 30 | 31 | Newcomers can start by trying to remove hayland/Graphics/Wayland/Scanner 32 | since it's made redundant by waymonad-scanner AFAICT, and then fixing 33 | the breakage that results in. 34 | 35 | ### hsroots 36 | 37 | hsroots needs a redesign so that it at least exposes a semi-safe interface, where you don't 38 | have to juggle pointers around like now. It also needs to run all wlroots functions from a 39 | single thread since it's not thread safe. Right now waymonad just isn't compiled with -threaded 40 | to avoid thread safety issues. 41 | The same is possibly true for hayland. 42 | 43 | The design I'm thinking of: 44 | - All wlroots function calls are delegated to a bound thread using a channel. 45 | - All "wlr objects" returned from the API will be wrapped in something like an `IORef Ptr`. 46 | - A signal handler on "wlr objects" will be installed onto the destroy event such that the above `IORef` is set to null atomically when the object is destroyed. 47 | - There will also have to be a finalizer on this that removes the signal handler from the destroy signal handler linked list. 48 | 49 | AFAICT there shouldn't be any thread-safety issues with the above. 50 | 51 | You are free to help implement the above. 52 | 53 | ## Troubleshooting 54 | 55 | Try running `nix-shell` instead if you're having problems inside the shell. 56 | Make sure to set `XDG_RUNTIME_DIR` and `WAYLAND_DISPLAY` if you do this. 57 | 58 | If you can't get it to build, try deleting dist-newstyle each time you change something, so that 59 | you can get a clean build. 60 | 61 | 62 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /assets/LICENSE: -------------------------------------------------------------------------------- 1 | LGPL is not very suitable for assets. 2 | Assets should have their license in the file if possible. 3 | 4 | Please make sure to list all used licenses here, and add a section about the 5 | license of a particular file, if it can't carry the information inline (because 6 | of format restrictions). 7 | 8 | Currently in use: 9 | CC-NC-SA: https://creativecommons.org/licenses/by-nc-sa/4.0/ 10 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: ./ ./hsroots ./hayland ./waymonad-scanner ./hsroots-new 2 | -- documentation: True 3 | -- haddock-all: True 4 | -------------------------------------------------------------------------------- /cbits/background.c: -------------------------------------------------------------------------------- 1 | /* Generated by wayland-scanner 1.14.0 */ 2 | 3 | /* 4 | * Copyright © 2017 Markus Ongyerth 5 | * 6 | * Permission is hereby granted, free of charge, to any person obtaining a copy 7 | * of this software and associated documentation files (the "Software"), to deal 8 | * in the Software without restriction, including without limitation the rights 9 | * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 10 | * copies of the Software, and to permit persons to whom the Software is 11 | * furnished to do so, subject to the following conditions: 12 | * 13 | * The above copyright notice and this permission notice shall be included in 14 | * all copies or substantial portions of the Software. 15 | * 16 | * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 17 | * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 18 | * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 19 | * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 20 | * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 21 | * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 22 | * SOFTWARE. 23 | */ 24 | 25 | #include 26 | #include 27 | #include "wayland-util.h" 28 | 29 | extern const struct wl_interface wl_output_interface; 30 | extern const struct wl_interface wl_surface_interface; 31 | extern const struct wl_interface z_background_surface_interface; 32 | 33 | static const struct wl_interface *types[] = { 34 | &z_background_surface_interface, 35 | &wl_surface_interface, 36 | &wl_output_interface, 37 | }; 38 | 39 | static const struct wl_message z_background_requests[] = { 40 | { "destroy", "", types + 0 }, 41 | { "get_background_surface", "no", types + 0 }, 42 | }; 43 | 44 | static const struct wl_message z_background_events[] = { 45 | { "create_background", "", types + 0 }, 46 | }; 47 | 48 | WL_EXPORT const struct wl_interface z_background_interface = { 49 | "z_background", 1, 50 | 2, z_background_requests, 51 | 1, z_background_events, 52 | }; 53 | 54 | static const struct wl_message z_background_surface_events[] = { 55 | { "remove", "", types + 0 }, 56 | { "set_output", "o", types + 2 }, 57 | }; 58 | 59 | WL_EXPORT const struct wl_interface z_background_surface_interface = { 60 | "z_background_surface", 1, 61 | 0, NULL, 62 | 2, z_background_surface_events, 63 | }; 64 | 65 | -------------------------------------------------------------------------------- /default.nix: -------------------------------------------------------------------------------- 1 | { pkgs ? import (import ./sources.nix).nixpkgs {} }: 2 | let pkgs' = pkgs; in 3 | let 4 | pkgs = pkgs'.extend (import ./overlay.nix); 5 | in pkgs.haskellPackages.waymonad 6 | -------------------------------------------------------------------------------- /hayland/.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | dist-newstyle 3 | cabal-dev 4 | *.o 5 | *.hi 6 | *.chi 7 | *.chs.h 8 | .cabal-sandbox 9 | cabal.sandbox.config 10 | TAGS 11 | tags 12 | -------------------------------------------------------------------------------- /hayland/Graphics/Wayland.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | 3 | module Graphics.Wayland ( 4 | version, Fixed256, Precision256, Time, Result(..), errToResult, 5 | diffTimeToTime, timeToDiffTime, ProtocolVersion(..), scannedVersionOf 6 | ) where 7 | 8 | import Foreign.C.Types 9 | import Data.Proxy 10 | 11 | import Graphics.Wayland.Internal.Util 12 | import Graphics.Wayland.Internal.Version 13 | 14 | 15 | data Result = Success | Failure deriving (Eq, Show) 16 | errToResult :: CInt -> Result 17 | errToResult 0 = Success 18 | errToResult (-1) = Failure 19 | 20 | class ProtocolVersion a where 21 | protocolVersion :: Proxy a -> Int 22 | 23 | scannedVersionOf :: forall a. (ProtocolVersion a) => a -> Int 24 | scannedVersionOf x = protocolVersion (Proxy :: Proxy a) 25 | -------------------------------------------------------------------------------- /hayland/Graphics/Wayland/Client.hs: -------------------------------------------------------------------------------- 1 | module Graphics.Wayland.Client ( 2 | -- Expose built-in wayland functions 3 | module Graphics.Wayland.Internal.Client, 4 | module Graphics.Wayland.Internal.Cursor, 5 | module Graphics.Wayland.Internal.EGL, 6 | -- Expose scanned protocol 7 | module Graphics.Wayland.Internal.SpliceClient, 8 | module Graphics.Wayland.Internal.SpliceClientTypes, 9 | ) where 10 | 11 | import Graphics.Wayland.Internal.Client 12 | import Graphics.Wayland.Internal.SpliceClient 13 | import Graphics.Wayland.Internal.SpliceClientTypes 14 | import Graphics.Wayland.Internal.Cursor 15 | import Graphics.Wayland.Internal.EGL 16 | -------------------------------------------------------------------------------- /hayland/Graphics/Wayland/Internal.hs: -------------------------------------------------------------------------------- 1 | module Graphics.Wayland.Internal where 2 | -------------------------------------------------------------------------------- /hayland/Graphics/Wayland/Internal/Cursor.chs: -------------------------------------------------------------------------------- 1 | -- | This is client-side code for loading cursor themes. Provided for convenience only. 2 | module Graphics.Wayland.Internal.Cursor ( 3 | CursorTheme, CursorImage, Cursor, 4 | cursorImageSize, cursorImageHotspot, cursorImageDelay, 5 | cursorName, cursorImages, 6 | 7 | cursorThemeLoad, cursorThemeDestroy, cursorThemeGetCursor, cursorImageGetBuffer, cursorFrame 8 | ) where 9 | 10 | import Control.Monad (liftM) 11 | import Foreign 12 | import Foreign.C.Types 13 | import Foreign.C.String 14 | import System.IO.Unsafe (unsafePerformIO) 15 | 16 | import Graphics.Wayland.Internal.SpliceClientTypes (Shm(..), Buffer(..)) 17 | 18 | #include 19 | 20 | {#context prefix="wl"#} 21 | 22 | 23 | -- | struct wl_cursor_theme; 24 | {#pointer * cursor_theme as CursorTheme newtype#} 25 | 26 | 27 | -- | struct wl_cursor_image { 28 | -- uint32_t width; /* actual width */ 29 | -- uint32_t height; /* actual height */ 30 | -- uint32_t hotspot_x; /* hot spot x (must be inside image) */ 31 | -- uint32_t hotspot_y; /* hot spot y (must be inside image) */ 32 | -- uint32_t delay; /* animation delay to next frame (ms) */ 33 | -- }; 34 | {#pointer * cursor_image as CursorImage newtype#} 35 | 36 | cursorImageSize :: CursorImage -> (Word, Word) 37 | cursorImageSize (CursorImage ci) = unsafePerformIO $ do -- CursorImages are immutable 38 | width <- {#get cursor_image->width#} ci 39 | height <- {#get cursor_image->height#} ci 40 | return (fromIntegral width, fromIntegral height) 41 | 42 | cursorImageHotspot :: CursorImage -> (Word, Word) 43 | cursorImageHotspot (CursorImage ci) = unsafePerformIO $ do -- CursorImages are immutable 44 | x <- {#get cursor_image->hotspot_x#} ci 45 | y <- {#get cursor_image->hotspot_y#} ci 46 | return (fromIntegral x, fromIntegral y) 47 | 48 | cursorImageDelay :: CursorImage -> Word 49 | cursorImageDelay (CursorImage ci) = unsafePerformIO $ liftM fromIntegral $ {#get cursor_image->delay#} ci -- CursorImages are immutable 50 | 51 | -- | struct wl_cursor { 52 | -- unsigned int image_count; 53 | -- struct wl_cursor_image **images; 54 | -- char *name; 55 | -- }; 56 | {#pointer * cursor as Cursor newtype#} 57 | cursorName :: Cursor -> String 58 | cursorName (Cursor c) = unsafePerformIO $ do 59 | cstr <- {#get cursor->name#} c 60 | peekCString cstr 61 | 62 | cursorImages :: Cursor -> [CursorImage] 63 | cursorImages (Cursor c) = unsafePerformIO $ do 64 | imagesPtr <- (\ ptr -> (peekByteOff ptr {#offsetof cursor->images#} :: IO (Ptr (Ptr CursorImage)))) c 65 | count <- {#get cursor->image_count#} c 66 | return imagesPtr 67 | ptrs <- peekArray (fromIntegral count) imagesPtr 68 | return $ map CursorImage ptrs 69 | 70 | -- struct wl_shm; 71 | {#pointer * shm as Shm nocode#} 72 | 73 | -- | struct wl_cursor_theme * 74 | -- wl_cursor_theme_load(const char *name, int size, struct wl_shm *shm); 75 | {#fun unsafe cursor_theme_load as cursorThemeLoad {`String', `Int', `Shm'} -> `CursorTheme'#} 76 | 77 | -- | void 78 | -- wl_cursor_theme_destroy(struct wl_cursor_theme *theme); 79 | {#fun unsafe cursor_theme_destroy as cursorThemeDestroy {`CursorTheme'} -> `()' #} 80 | 81 | -- | struct wl_cursor * 82 | -- wl_cursor_theme_get_cursor(struct wl_cursor_theme *theme, 83 | -- const char *name); 84 | {#fun unsafe cursor_theme_get_cursor as cursorThemeGetCursor {`CursorTheme', `String'} -> `Cursor' #} 85 | 86 | {#pointer * buffer as Buffer nocode#} 87 | -- | struct wl_buffer * 88 | -- wl_cursor_image_get_buffer(struct wl_cursor_image *image); 89 | -- 90 | -- From the wayland docs: do not destroy the returned buffer. 91 | {#fun unsafe cursor_image_get_buffer as cursorImageGetBuffer {`CursorImage'} -> `Buffer' #} 92 | 93 | -- | int 94 | -- wl_cursor_frame(struct wl_cursor *cursor, uint32_t time); 95 | {#fun unsafe cursor_frame as cursorFrame {`Cursor', `Int'} -> `Int' #} 96 | -------------------------------------------------------------------------------- /hayland/Graphics/Wayland/Internal/EGL.chs: -------------------------------------------------------------------------------- 1 | -- | Client-side 2 | module Graphics.Wayland.Internal.EGL ( 3 | EGLWindow, eglWindowCreate, eglWindowDestroy, eglWindowResize, eglWindowGetAttachedSize 4 | ) where 5 | 6 | 7 | import Control.Monad 8 | import Foreign 9 | import Foreign.C.Types 10 | import Foreign.C.String 11 | 12 | import Graphics.Wayland.Internal.SpliceClientTypes (Surface(..)) 13 | 14 | #include 15 | 16 | {#context prefix="wl"#} 17 | 18 | 19 | -- lol this is 100% unused. 20 | -- #define WL_EGL_PLATFORM 1 21 | 22 | {#pointer * surface as Surface nocode#} 23 | 24 | -- struct wl_egl_window; 25 | {#pointer * egl_window as EGLWindow newtype#} 26 | 27 | -- struct wl_egl_window * 28 | -- wl_egl_window_create(struct wl_surface *surface, 29 | -- int width, int height); 30 | {#fun unsafe egl_window_create as eglWindowCreate {`Surface', `Int', `Int'} -> `EGLWindow' #} 31 | 32 | -- void 33 | -- wl_egl_window_destroy(struct wl_egl_window *egl_window); 34 | {#fun unsafe egl_window_destroy as eglWindowDestroy {`EGLWindow'} -> `()' #} 35 | 36 | -- void 37 | -- wl_egl_window_resize(struct wl_egl_window *egl_window, 38 | -- int width, int height, 39 | -- int dx, int dy); 40 | {#fun unsafe egl_window_resize as eglWindowResize {`EGLWindow', `Int', `Int', `Int', `Int'} -> `()' #} 41 | 42 | 43 | -- void 44 | -- wl_egl_window_get_attached_size(struct wl_egl_window *egl_window, 45 | -- int *width, int *height); 46 | -- withInt = with.fromIntegral 0 47 | peekInt = liftM fromIntegral . peek 48 | {#fun unsafe egl_window_get_attached_size as eglWindowGetAttachedSize {`EGLWindow', alloca- `Int' peekInt*, alloca- `Int' peekInt*} -> `()' #} 49 | -------------------------------------------------------------------------------- /hayland/Graphics/Wayland/Internal/ServerClientState.chs: -------------------------------------------------------------------------------- 1 | module Graphics.Wayland.Internal.ServerClientState where 2 | 3 | #include 4 | 5 | {#enum define ClientStateNums { 6 | WL_EVENT_READABLE as ClientReadable, 7 | WL_EVENT_WRITABLE as ClientWritable, 8 | WL_EVENT_HANGUP as ClientHangup, 9 | WL_EVENT_ERROR as ClientError} #} -------------------------------------------------------------------------------- /hayland/Graphics/Wayland/Internal/SpliceClient.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell, ForeignFunctionInterface #-} 2 | 3 | module Graphics.Wayland.Internal.SpliceClient where 4 | 5 | import Data.Functor 6 | import Language.Haskell.TH 7 | import Foreign.C.Types 8 | 9 | import Graphics.Wayland.Scanner.Protocol 10 | import Graphics.Wayland.Scanner 11 | import Graphics.Wayland.Internal.SpliceClientTypes 12 | import qualified Graphics.Wayland.Internal.SpliceClientInternal as Import 13 | 14 | 15 | $(runIO readProtocol >>= generateClientExports) 16 | -------------------------------------------------------------------------------- /hayland/Graphics/Wayland/Internal/SpliceClientInternal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell, ForeignFunctionInterface #-} 2 | 3 | module Graphics.Wayland.Internal.SpliceClientInternal where 4 | 5 | import Data.Functor 6 | import Language.Haskell.TH 7 | import Foreign.C.Types 8 | 9 | import Graphics.Wayland.Scanner.Protocol 10 | import Graphics.Wayland.Scanner 11 | import Graphics.Wayland.Internal.SpliceClientTypes 12 | 13 | 14 | $(runIO readProtocol >>= generateClientInternal) 15 | -------------------------------------------------------------------------------- /hayland/Graphics/Wayland/Internal/SpliceClientTypes.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell, ForeignFunctionInterface #-} 2 | 3 | module Graphics.Wayland.Internal.SpliceClientTypes where 4 | 5 | import Data.Functor 6 | import Language.Haskell.TH 7 | import Foreign.C.Types 8 | 9 | import Graphics.Wayland.Scanner.Protocol 10 | import Graphics.Wayland.Scanner 11 | 12 | $(runIO readProtocol >>= generateClientTypes) 13 | -------------------------------------------------------------------------------- /hayland/Graphics/Wayland/Internal/SpliceServer.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell, ForeignFunctionInterface #-} 2 | 3 | module Graphics.Wayland.Internal.SpliceServer where 4 | 5 | import Data.Functor 6 | import Language.Haskell.TH 7 | import Foreign.C.Types 8 | 9 | import Graphics.Wayland.Scanner.Protocol 10 | import Graphics.Wayland.Scanner 11 | import qualified Graphics.Wayland.Internal.SpliceServerInternal as Import 12 | 13 | 14 | $(runIO readProtocol >>= generateServerExports) 15 | -------------------------------------------------------------------------------- /hayland/Graphics/Wayland/Internal/SpliceServerInternal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell, ForeignFunctionInterface #-} 2 | 3 | module Graphics.Wayland.Internal.SpliceServerInternal where 4 | 5 | import Data.Functor 6 | import Language.Haskell.TH 7 | import Foreign.C.Types 8 | 9 | import Graphics.Wayland.Scanner.Protocol 10 | import Graphics.Wayland.Scanner 11 | import Graphics.Wayland.Internal.Util 12 | import Graphics.Wayland.Internal.SpliceServerTypes 13 | 14 | 15 | $(runIO readProtocol >>= generateServerInternal) 16 | -------------------------------------------------------------------------------- /hayland/Graphics/Wayland/Internal/SpliceServerTypes.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell, ForeignFunctionInterface #-} 2 | 3 | module Graphics.Wayland.Internal.SpliceServerTypes where 4 | 5 | import Data.Functor 6 | import Language.Haskell.TH 7 | import Foreign.C.Types 8 | 9 | import Graphics.Wayland.Scanner.Protocol 10 | import Graphics.Wayland.Scanner 11 | 12 | $(runIO readProtocol >>= generateServerTypes) 13 | -------------------------------------------------------------------------------- /hayland/Graphics/Wayland/Internal/Util.chs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | module Graphics.Wayland.Internal.Util ( 3 | CInterface(..), Client(..), 4 | 5 | Fixed256, Precision256, 6 | 7 | Time, millisecondsToTime, timeToMilliseconds, diffTimeToTime, timeToDiffTime 8 | ) where 9 | 10 | import Data.Ratio ((%)) 11 | import Data.Time.Clock (DiffTime) 12 | import Data.Fixed (Fixed(..), HasResolution(..), Milli(..)) 13 | import Data.Typeable 14 | import Data.Functor 15 | import Foreign 16 | import Foreign.C.Types 17 | import Foreign.C.String 18 | 19 | #include 20 | #include 21 | 22 | {#context prefix="wl"#} 23 | 24 | 25 | -- | struct wl_interface pointer 26 | {#pointer * interface as CInterface newtype#} 27 | 28 | 29 | 30 | -- | opaque server-side wl_client struct 31 | newtype Client = Client (Ptr Client) deriving (Eq) 32 | 33 | -- | 8 bits of precision means a resolution of 256. 34 | data Precision256 = Precision256 deriving (Typeable) 35 | instance HasResolution Precision256 where 36 | resolution _ = 256 37 | -- | Fixed point number with 8 bits of decimal precision. 38 | -- 39 | -- The equivalent of wayland's wl_fixed_t. 40 | type Fixed256 = Fixed Precision256 41 | 42 | -- | Represents time in seconds with millisecond precision. 43 | -- 44 | -- 45 | type Time = Milli 46 | 47 | millisecondsToTime :: CUInt -> Time 48 | millisecondsToTime = MkFixed . fromIntegral 49 | timeToMilliseconds :: Time -> CUInt 50 | timeToMilliseconds (MkFixed n) = fromIntegral n 51 | 52 | timeToDiffTime :: Time -> DiffTime 53 | timeToDiffTime (MkFixed n) = fromRational (n % 1000) 54 | 55 | diffTimeToTime :: DiffTime -> Time 56 | diffTimeToTime = fromRational . toRational 57 | -------------------------------------------------------------------------------- /hayland/Graphics/Wayland/Internal/Version.chs: -------------------------------------------------------------------------------- 1 | module Graphics.Wayland.Internal.Version (version) where 2 | 3 | #include 4 | 5 | {#enum define VersionInt {WAYLAND_VERSION_MAJOR as MajorInt, WAYLAND_VERSION_MINOR as MinorInt, WAYLAND_VERSION_MICRO as MicroInt} deriving (Eq, Ord) #} 6 | 7 | version = (fromEnum MajorInt, fromEnum MinorInt, fromEnum MicroInt) 8 | -------------------------------------------------------------------------------- /hayland/Graphics/Wayland/Scanner/Types.chs: -------------------------------------------------------------------------------- 1 | module Graphics.Wayland.Scanner.Types where 2 | 3 | import Foreign 4 | import Language.Haskell.TH (Name) 5 | 6 | #include 7 | 8 | {#context prefix="wl"#} 9 | 10 | data ServerClient = Server | Client deriving (Eq) 11 | 12 | -- | wayland-style interface name (e.g. wl_display) 13 | type InterfaceName = String 14 | data Interface = Interface { 15 | interfaceName :: InterfaceName, 16 | interfaceVersion :: Int, 17 | interfaceRequests :: [Message], -- ^ aka requests 18 | interfaceEvents :: [Message], 19 | interfaceEnums :: [WLEnum] 20 | } deriving (Show) 21 | 22 | type EnumName = String 23 | -- | wayland style enum specification (not Prelude) 24 | data WLEnum = WLEnum { 25 | enumName :: EnumName, 26 | enumEntries :: [(String,Int)] 27 | } deriving (Show) 28 | 29 | -- | wayland wire protocol argument type. we can't deal with untyped object/new-id arguments. 30 | data ArgumentType = IntArg | UIntArg | FixedArg | StringArg | ObjectArg Name | NewIdArg Name MessageName | ArrayArg | FdArg deriving (Show) 31 | argConversionTable :: [(String, ArgumentType)] -- for all easy argument types 32 | argConversionTable = [ 33 | ("int", IntArg), 34 | ("uint", UIntArg), 35 | ("fixed", FixedArg), 36 | ("string", StringArg), 37 | ("fd", FdArg), 38 | ("array", ArrayArg)] 39 | 40 | type Argument = (String, ArgumentType, Bool) -- name, argument type, allow-null 41 | 42 | type MessageName = String 43 | data Message = Message { 44 | messageName :: MessageName, 45 | messageArguments :: [Argument], 46 | messageIsDestructor :: Bool 47 | } deriving (Show) 48 | 49 | type ProtocolName = String 50 | data ProtocolSpec = ProtocolSpec { 51 | protocolName :: ProtocolName, 52 | protocolInterfaces :: [Interface] 53 | } deriving (Show) 54 | 55 | {#pointer * array as WLArray#} 56 | -------------------------------------------------------------------------------- /hayland/Graphics/Wayland/Server.hs: -------------------------------------------------------------------------------- 1 | module Graphics.Wayland.Server ( 2 | -- Expose built-in wayland functions 3 | module Graphics.Wayland.Internal.Server, 4 | Client(..), 5 | -- Expose scanned protocol 6 | module Graphics.Wayland.Internal.SpliceServer, 7 | module Graphics.Wayland.Internal.SpliceServerTypes, 8 | ) where 9 | 10 | import Graphics.Wayland.Internal.Server 11 | import Graphics.Wayland.Internal.SpliceServer 12 | import Graphics.Wayland.Internal.SpliceServerTypes 13 | import Graphics.Wayland.Internal.Util (Client(..)) 14 | -------------------------------------------------------------------------------- /hayland/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2014 Auke Booij 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be included 12 | in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 17 | IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY 18 | CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, 19 | TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE 20 | SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /hayland/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /hayland/default.nix: -------------------------------------------------------------------------------- 1 | { pkgs ? import {} }: 2 | pkgs.haskellPackages.callPackage ./hayland.nix {} 3 | -------------------------------------------------------------------------------- /hayland/hayland.cabal: -------------------------------------------------------------------------------- 1 | -- Initial haskell-wayland.cabal generated by cabal init. For further 2 | -- documentation, see http://haskell.org/cabal/users-guide/ 3 | 4 | name: hayland 5 | version: 0.1.1.0 6 | synopsis: Haskell bindings for the C Wayland library. 7 | description: This package contains bindings to the Wayland library, which is used to interface display devices, drawable clients, and window managers. 8 | . 9 | Wayland exposes a fixed set of functions, and additionally generates a (large) part of its API from a _protocol_ file using Template Haskell. 10 | This package locates that protocol file using @pkg-config@. 11 | . 12 | If you want to interface with other protocols (such as Weston's), refer to the readme for instructions. 13 | license: MIT 14 | license-file: LICENSE 15 | author: Auke Booij 16 | maintainer: auke@tulcod.com 17 | -- copyright: 18 | category: Graphics 19 | build-type: Simple 20 | extra-source-files: README.md, NOTES.md 21 | cabal-version: >=1.10 22 | 23 | source-repository head 24 | type: git 25 | location: https://github.com/tulcod/haskell-wayland 26 | 27 | library 28 | exposed-modules: 29 | Graphics.Wayland, 30 | Graphics.Wayland.Client, 31 | Graphics.Wayland.Server, 32 | Graphics.Wayland.Scanner 33 | other-modules: 34 | Graphics.Wayland.Internal, 35 | Graphics.Wayland.Internal.Client, 36 | Graphics.Wayland.Internal.Cursor, 37 | Graphics.Wayland.Internal.EGL, 38 | Graphics.Wayland.Internal.ServerClientState, 39 | Graphics.Wayland.Internal.Server, 40 | Graphics.Wayland.Internal.Util, 41 | Graphics.Wayland.Internal.Version, 42 | Graphics.Wayland.Internal.SpliceClient, 43 | Graphics.Wayland.Internal.SpliceServer, 44 | Graphics.Wayland.Internal.SpliceClientTypes, 45 | Graphics.Wayland.Internal.SpliceServerTypes, 46 | Graphics.Wayland.Internal.SpliceClientInternal, 47 | Graphics.Wayland.Internal.SpliceServerInternal, 48 | Graphics.Wayland.Scanner.Marshaller, 49 | Graphics.Wayland.Scanner.Names, 50 | Graphics.Wayland.Scanner.Protocol, 51 | Graphics.Wayland.Scanner.Types 52 | build-depends: base >=4.7 && <5, xml >= 1.3 && < 1.4, process >= 1.1 && < 2, template-haskell >= 2 && < 3, data-flags <0.1, time, transformers 53 | build-tools: pkg-config 54 | default-extensions: ForeignFunctionInterface 55 | -- hs-source-dirs: 56 | default-language: Haskell2010 57 | cc-options: -fPIC 58 | -- ghc-options: -ddump-splices 59 | pkgconfig-depends: 60 | wayland-client, 61 | wayland-cursor, 62 | wayland-egl, 63 | wayland-server 64 | includes: 65 | wayland-client.h, 66 | wayland-server.h, 67 | wayland-client-protocol.h, 68 | wayland-server-protocol.h, 69 | wayland-util.h, 70 | wayland-version.h, 71 | wayland-egl.h 72 | 73 | -- FIXME: this tests assumes there's a wayland server (e.g. weston) running. 74 | test-suite firsttest 75 | hs-source-dirs: tests 76 | type: exitcode-stdio-1.0 77 | main-is: test.hs 78 | build-depends: base, hayland, xml, process 79 | default-language: Haskell2010 80 | 81 | test-suite enumtest 82 | hs-source-dirs: tests 83 | type: exitcode-stdio-1.0 84 | main-is: enums.hs 85 | build-depends: base, hayland, xml, process 86 | default-language: Haskell2010 87 | 88 | executable wayland-list-globals 89 | hs-source-dirs: tests 90 | main-is: listglobals.hs 91 | build-depends: base, hayland 92 | default-language: Haskell2010 93 | -------------------------------------------------------------------------------- /hayland/hayland.nix: -------------------------------------------------------------------------------- 1 | { mkDerivation, base, c2hs, data-flags, lib, libGL, pkg-config 2 | , process, template-haskell, time, transformers, wayland, xml 3 | }: 4 | mkDerivation { 5 | pname = "hayland"; 6 | version = "0.1.1.0"; 7 | src = ./.; 8 | isLibrary = true; 9 | isExecutable = true; 10 | libraryHaskellDepends = [ 11 | base data-flags process template-haskell time transformers xml c2hs 12 | ]; 13 | libraryPkgconfigDepends = [ libGL wayland ]; 14 | libraryToolDepends = [ c2hs pkg-config ]; 15 | executableHaskellDepends = [ base c2hs ]; 16 | testHaskellDepends = [ base process xml c2hs ]; 17 | description = "Haskell bindings for the C Wayland library"; 18 | license = lib.licenses.mit; 19 | doCheck = false; # it needs a wayland server available when testing 20 | } 21 | -------------------------------------------------------------------------------- /hayland/shell.nix: -------------------------------------------------------------------------------- 1 | { pkgs ? import {} }: 2 | pkgs.haskellPackages.shellFor { 3 | packages = p: [ (p.callPackage ./hayland.nix {}) ]; 4 | withHoogle = true; 5 | buildInputs = [ pkgs.cabal-install pkgs.cabal2nix ]; 6 | } 7 | -------------------------------------------------------------------------------- /hayland/tests/enums.hs: -------------------------------------------------------------------------------- 1 | import Graphics.Wayland.Client 2 | 3 | a :: DisplayError 4 | a = displayErrorInvalidMethod 5 | 6 | main = print a 7 | -------------------------------------------------------------------------------- /hayland/tests/listglobals.hs: -------------------------------------------------------------------------------- 1 | import Control.Concurrent 2 | 3 | import Graphics.Wayland.Client 4 | 5 | main = do 6 | connect <- displayConnect 7 | let display = case connect of 8 | Just x -> x 9 | Nothing -> error "couldn't connect to a wayland server." 10 | fd <- displayGetFd display 11 | putStrLn $ "Using file descriptor " ++ show fd 12 | putStrLn $ "Display at " ++ show display 13 | registry <- displayGetRegistry display 14 | putStrLn $ "Registry at "++ show registry 15 | let listener = RegistryListener { 16 | registryGlobal = \reg name ifacename version -> putStrLn $ "Received global " ++ show name ++ " (" ++ ifacename ++ ") version " ++ show version, 17 | registryGlobalRemove = \ _ _ -> return () 18 | } 19 | errorCode <- registrySetListener registry listener 20 | putStrLn $ "Setting registry listener... " ++ show errorCode 21 | 22 | res <- displayPrepareRead display 23 | putStrLn $ "Preparing read... " ++ show res 24 | flushed <- displayFlush display 25 | putStrLn $ "Flushed " ++ show flushed 26 | putStrLn "polling" 27 | threadWaitRead fd 28 | putStrLn $ "Ready to read." 29 | events <- displayReadEvents display 30 | putStrLn $ "Read display events: " ++ show events 31 | dispatched <- displayDispatchPending display 32 | putStrLn $ "Dispatched events: " ++ show dispatched 33 | displayDisconnect display 34 | -------------------------------------------------------------------------------- /hayland/tests/test.hs: -------------------------------------------------------------------------------- 1 | import Control.Concurrent 2 | 3 | import Graphics.Wayland (scannedVersionOf) 4 | import Graphics.Wayland.Client 5 | 6 | main = do 7 | connect <- displayConnect 8 | print connect 9 | let display = case connect of 10 | Just x -> x 11 | Nothing -> error "could not connect to a wayland server" 12 | 13 | putStrLn $ "Using Display with scanned version "++ (show $ scannedVersionOf display) 14 | putStrLn $ "Using Surface with scanned version "++ (show $ scannedVersionOf (undefined::Surface)) 15 | 16 | b <- displaySync display 17 | print b 18 | let listener = CallbackListener { 19 | callbackDone = \ _ _ -> putStrLn "received done" 20 | } 21 | callbackSetListener b listener 22 | displayFlush display 23 | displayGetFd display >>= threadWaitRead 24 | displayDispatch display 25 | -------------------------------------------------------------------------------- /hsroots-new/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2021 Las Safin 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining a copy of 4 | this software and associated documentation files (the "Software"), to deal in 5 | the Software without restriction, including without limitation the rights to 6 | use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies 7 | of the Software, and to permit persons to whom the Software is furnished to do 8 | so, subject to the following conditions: 9 | 10 | The above copyright notice and this permission notice shall be included in all 11 | copies or substantial portions of the Software. 12 | 13 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 14 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 15 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 16 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 17 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 18 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 19 | SOFTWARE. 20 | -------------------------------------------------------------------------------- /hsroots-new/WlRoots/Backend.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | 3 | module WlRoots.Backend where 4 | 5 | import WlRoots.Internal.Generate (generateBindings) 6 | 7 | $(generateBindings "backend") 8 | -------------------------------------------------------------------------------- /hsroots-new/WlRoots/Internal/Generate.hs: -------------------------------------------------------------------------------- 1 | module WlRoots.Internal.Generate (generateBindings) where 2 | 3 | import Control.Monad.IO.Class (MonadIO (..)) 4 | import Language.C (parseCFilePre) 5 | import Language.C.Syntax.AST 6 | import Language.Haskell.TH (Dec, Q) 7 | import System.IO (hClose, hPutStr) 8 | import System.IO.Temp (withSystemTempFile) 9 | import System.Process (callProcess, readProcess) 10 | 11 | handleDecl :: CExtDecl -> [Dec] 12 | handleDecl (CDeclExt (CDecl _ty _subdecls _)) = error "unimplemented" 13 | handleDecl x = error $ "unimplemented:" <> show x 14 | 15 | generateBindings :: FilePath -> Q [Dec] 16 | generateBindings header = liftIO $ do 17 | Right (CTranslUnit decls _) <- 18 | withSystemTempFile "wlroots-header-include.c" $ \path handle -> 19 | withSystemTempFile "wlroots-header-include.i" $ \pathi handlei -> do 20 | hPutStr handle $ "#define WLR_USE_UNSTABLE\n#include header <> ".h>" 21 | hClose handle 22 | hClose handlei 23 | flags <- readProcess "pkg-config" ["--cflags", "wlroots", "wayland-server", "pixman-1", "libudev"] "" 24 | callProcess "cc" $ words flags <> ["-E", path, "-o", pathi] 25 | parseCFilePre $ pathi 26 | pure $ foldMap handleDecl decls 27 | -------------------------------------------------------------------------------- /hsroots-new/hsroots.cabal: -------------------------------------------------------------------------------- 1 | name: hsroots-new 2 | -- FIXME: rename to hsroots 3 | version: 0.1.0.0 4 | synopsis: Automatically generated bindings for wlroots 5 | license: MIT 6 | license-file: LICENSE 7 | author: Las Safin 8 | maintainer: las@protonmail.ch 9 | category: Graphics 10 | build-type: Simple 11 | extra-source-files: ChangeLog.md 12 | cabal-version: 2.0 13 | 14 | library 15 | exposed-modules: WlRoots.Backend 16 | other-modules: WlRoots.Internal.Generate 17 | 18 | build-depends: base >=4.7 && <5, 19 | composition >= 1.0.2 && < 1.1, 20 | hayland, xkbcommon, bytestring, text, 21 | libinput, unix, language-c, template-haskell, 22 | process, temporary 23 | 24 | default-language: Haskell2010 25 | default-extensions: TemplateHaskellQuotes 26 | ghc-options: -Wall 27 | 28 | pkgconfig-depends: wayland-server, pixman-1, wlroots, libudev 29 | -------------------------------------------------------------------------------- /hsroots-new/hsroots.nix: -------------------------------------------------------------------------------- 1 | { mkDerivation, base, bytestring, composition, hayland, lib 2 | , hslibinput, pixman, text, unix, wayland, wlroots, xkbcommon 3 | , libX11, fetchFromGitHub, freerdp, mesa, wayland-scanner 4 | , runCommand, wayland-protocols, language-c, process, template-haskell 5 | , temporary, libudev 6 | }: 7 | let 8 | wlroots' = wlroots.overrideAttrs (o: rec { 9 | version = "0.14.1"; 10 | src = fetchFromGitHub { 11 | owner = "swaywm"; 12 | repo = "wlroots"; 13 | rev = version; 14 | sha256 = "wauk7TCL/V7fxjOZY77KiPbfydIc9gmOiYFOuum4UOs="; 15 | }; 16 | }); 17 | s = "${wayland-scanner}/bin/wayland-scanner"; 18 | protocols = runCommand "protocols" {} '' 19 | mkdir -p "$out/include" 20 | for f in ${wlroots'.src}/protocol/*.xml ; do 21 | ${s} "server-header" "$f" "$out/include/$(basename "$f" .xml)-protocol.h" 22 | ${s} "client-header" "$f" "$out/include/$(basename "$f" .xml)-client-protocol.h" 23 | done 24 | for f in $(find ${wayland-protocols} -name '*.xml') ; do 25 | ${s} "server-header" "$f" "$out/include/$(basename "$f" .xml)-protocol.h" 26 | ${s} "client-header" "$f" "$out/include/$(basename "$f" .xml)-client-protocol.h" 27 | done 28 | ''; 29 | in mkDerivation { 30 | pname = "hsroots-new"; 31 | version = "0.1.0.0"; 32 | src = ./.; 33 | libraryHaskellDepends = [ 34 | base bytestring composition hayland hslibinput text unix xkbcommon language-c process template-haskell temporary 35 | ]; 36 | librarySystemDepends = [ libX11 mesa protocols ]; 37 | libraryPkgconfigDepends = [ wayland pixman wlroots' libudev ]; 38 | description = "Automatically generated bindings for wlroots"; 39 | license = lib.licenses.mit; 40 | } 41 | -------------------------------------------------------------------------------- /hsroots/.gitignore: -------------------------------------------------------------------------------- 1 | dist-newstyle 2 | dist 3 | *.swp 4 | *.swo 5 | -------------------------------------------------------------------------------- /hsroots/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 | -------------------------------------------------------------------------------- /hsroots/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 | -------------------------------------------------------------------------------- /hsroots/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /hsroots/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 | -------------------------------------------------------------------------------- /hsroots/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 | -------------------------------------------------------------------------------- /hsroots/hsroots.cabal: -------------------------------------------------------------------------------- 1 | name: hsroots 2 | version: 0.1.0.0 3 | synopsis: A small simple wrapper around wlroots 4 | license: LGPL-2.1 5 | license-file: LICENSE 6 | author: Markus Ongyerth 7 | maintainer: ongy@ongy.net 8 | category: Graphics 9 | build-type: Simple 10 | extra-source-files: ChangeLog.md 11 | cabal-version: >=1.10 12 | 13 | library 14 | exposed-modules: Graphics.Egl 15 | exposed-modules: Graphics.Pixman 16 | exposed-modules: Graphics.Wayland.Global 17 | exposed-modules: Graphics.Wayland.List 18 | exposed-modules: Graphics.Wayland.Resource 19 | exposed-modules: Graphics.Wayland.Server.Client 20 | exposed-modules: Graphics.Wayland.Signal 21 | exposed-modules: Graphics.Wayland.WlRoots.Backend 22 | exposed-modules: Graphics.Wayland.WlRoots.Backend.Headless 23 | exposed-modules: Graphics.Wayland.WlRoots.Backend.Libinput 24 | exposed-modules: Graphics.Wayland.WlRoots.Backend.Multi 25 | exposed-modules: Graphics.Wayland.WlRoots.Backend.Session 26 | exposed-modules: Graphics.Wayland.WlRoots.Box 27 | exposed-modules: Graphics.Wayland.WlRoots.Buffer 28 | exposed-modules: Graphics.Wayland.WlRoots.Compositor 29 | exposed-modules: Graphics.Wayland.WlRoots.Cursor 30 | exposed-modules: Graphics.Wayland.WlRoots.DataControl 31 | exposed-modules: Graphics.Wayland.WlRoots.DeviceManager 32 | exposed-modules: Graphics.Wayland.WlRoots.ExportDMABuf 33 | exposed-modules: Graphics.Wayland.WlRoots.Egl 34 | exposed-modules: Graphics.Wayland.WlRoots.Global 35 | exposed-modules: Graphics.Wayland.WlRoots.IdleInhibit 36 | exposed-modules: Graphics.Wayland.WlRoots.Input 37 | exposed-modules: Graphics.Wayland.WlRoots.Input.Buttons 38 | exposed-modules: Graphics.Wayland.WlRoots.Input.Keyboard 39 | exposed-modules: Graphics.Wayland.WlRoots.Input.Pointer 40 | exposed-modules: Graphics.Wayland.WlRoots.Input.Tablet 41 | exposed-modules: Graphics.Wayland.WlRoots.Input.TabletPad 42 | exposed-modules: Graphics.Wayland.WlRoots.Input.TabletTool 43 | exposed-modules: Graphics.Wayland.WlRoots.Input.Touch 44 | exposed-modules: Graphics.Wayland.WlRoots.InputInhibitor 45 | exposed-modules: Graphics.Wayland.WlRoots.LinuxDMABuf 46 | exposed-modules: Graphics.Wayland.WlRoots.Output 47 | exposed-modules: Graphics.Wayland.WlRoots.OutputLayout 48 | exposed-modules: Graphics.Wayland.WlRoots.Render 49 | exposed-modules: Graphics.Wayland.WlRoots.Render.Color 50 | exposed-modules: Graphics.Wayland.WlRoots.Render.Gles2 51 | exposed-modules: Graphics.Wayland.WlRoots.Render.Matrix 52 | exposed-modules: Graphics.Wayland.WlRoots.Seat 53 | exposed-modules: Graphics.Wayland.WlRoots.ServerDecoration 54 | exposed-modules: Graphics.Wayland.WlRoots.Surface 55 | exposed-modules: Graphics.Wayland.WlRoots.SurfaceLayers 56 | exposed-modules: Graphics.Wayland.WlRoots.Tabletv2 57 | exposed-modules: Graphics.Wayland.WlRoots.Util 58 | exposed-modules: Graphics.Wayland.WlRoots.Util.Region 59 | exposed-modules: Graphics.Wayland.WlRoots.XCursor 60 | exposed-modules: Graphics.Wayland.WlRoots.XCursorManager 61 | exposed-modules: Graphics.Wayland.WlRoots.XWayland 62 | exposed-modules: Graphics.Wayland.WlRoots.XdgShell 63 | 64 | other-modules: Utility 65 | 66 | build-depends: base >=4.7 && <5, 67 | composition >= 1.0.2 && < 1.1, 68 | hayland, xkbcommon, bytestring, text, 69 | libinput, unix 70 | 71 | hs-source-dirs: src 72 | 73 | default-language: Haskell2010 74 | ghc-options: -Wall 75 | 76 | pkgconfig-depends: wayland-server, pixman-1, wlroots 77 | 78 | c-sources: cbits/signal.c 79 | 80 | -------------------------------------------------------------------------------- /hsroots/hsroots.nix: -------------------------------------------------------------------------------- 1 | { mkDerivation, base, bytestring, composition, hayland, lib 2 | , hslibinput, pixman, text, unix, wayland, wlroots, xkbcommon 3 | , libX11, fetchFromGitHub, freerdp, mesa, wayland-scanner 4 | , runCommand, wayland-protocols 5 | }: 6 | let 7 | wlroots' = wlroots.overrideAttrs (o: rec { 8 | version = "0.14.1"; 9 | src = fetchFromGitHub { 10 | owner = "swaywm"; 11 | repo = "wlroots"; 12 | rev = version; 13 | sha256 = "wauk7TCL/V7fxjOZY77KiPbfydIc9gmOiYFOuum4UOs="; 14 | }; 15 | }); 16 | s = "${wayland-scanner}/bin/wayland-scanner"; 17 | protocols = runCommand "protocols" {} '' 18 | mkdir -p "$out/include" 19 | for f in ${wlroots'.src}/protocol/*.xml ; do 20 | ${s} "server-header" "$f" "$out/include/$(basename "$f" .xml)-protocol.h" 21 | ${s} "client-header" "$f" "$out/include/$(basename "$f" .xml)-client-protocol.h" 22 | done 23 | for f in $(find ${wayland-protocols} -name '*.xml') ; do 24 | ${s} "server-header" "$f" "$out/include/$(basename "$f" .xml)-protocol.h" 25 | ${s} "client-header" "$f" "$out/include/$(basename "$f" .xml)-client-protocol.h" 26 | done 27 | ''; 28 | in mkDerivation { 29 | pname = "hsroots"; 30 | version = "0.1.0.0"; 31 | src = ./.; 32 | libraryHaskellDepends = [ 33 | base bytestring composition hayland hslibinput text unix xkbcommon 34 | ]; 35 | librarySystemDepends = [ libX11 mesa protocols ]; 36 | libraryPkgconfigDepends = [ wayland pixman wlroots' ]; 37 | description = "A small simple wrapper around wlroots"; 38 | license = lib.licenses.lgpl21Only; 39 | } 40 | -------------------------------------------------------------------------------- /hsroots/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 | -------------------------------------------------------------------------------- /hsroots/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 | -------------------------------------------------------------------------------- /hsroots/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 | -------------------------------------------------------------------------------- /hsroots/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 safe "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 safe "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 safe "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 safe "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 safe "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 | -------------------------------------------------------------------------------- /hsroots/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 safe "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 | -------------------------------------------------------------------------------- /hsroots/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 safe "wlr_backend_autocreate" c_backend_autocreate :: Ptr DisplayServer -> IO (Ptr Backend) 30 | 31 | backendAutocreate :: DisplayServer -> IO (Ptr Backend) 32 | backendAutocreate (DisplayServer ptr) = throwErrnoIfNull "backendAutocreate" $ c_backend_autocreate ptr 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 safe "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 | -------------------------------------------------------------------------------- /hsroots/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 safe "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 safe "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 safe "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 | -------------------------------------------------------------------------------- /hsroots/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 safe "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 safe "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 safe "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 | -------------------------------------------------------------------------------- /hsroots/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 safe "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 | -------------------------------------------------------------------------------- /hsroots/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 safe "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 | -------------------------------------------------------------------------------- /hsroots/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_client_buffer, resource} ptr 24 | if ret == nullPtr 25 | then pure Nothing 26 | else pure $ Just ret 27 | 28 | -- NB: This works because the first element in a wlr_client_buffer is a wlr_buffer 29 | foreign import ccall safe "wlr_buffer_lock" c_ref :: Ptr WlrBuffer -> IO () 30 | 31 | getBuffer :: WlrBuffer -> IO WlrBuffer 32 | getBuffer b@(WlrBuffer ptr) = c_ref ptr >> pure b 33 | 34 | -- NB: This works because the first element in a wlr_client_buffer is a wlr_buffer 35 | foreign import ccall safe "wlr_buffer_unlock" c_unref :: Ptr WlrBuffer -> IO () 36 | 37 | putBuffer :: WlrBuffer -> IO () 38 | putBuffer (WlrBuffer ptr) = c_unref ptr 39 | 40 | getTexture :: WlrBuffer -> IO (Maybe (Ptr Texture)) 41 | getTexture (WlrBuffer ptr) = do 42 | ret <- #{peek struct wlr_client_buffer, texture} ptr 43 | if ret == nullPtr 44 | then pure Nothing 45 | else pure $ Just ret 46 | -------------------------------------------------------------------------------- /hsroots/src/Graphics/Wayland/WlRoots/Compositor.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE EmptyDataDecls #-} 2 | module Graphics.Wayland.WlRoots.Compositor 3 | ( WlrCompositor 4 | , compositorCreate 5 | ) 6 | where 7 | 8 | import Foreign.Ptr (Ptr) 9 | import Foreign.C.Error (throwErrnoIfNull) 10 | import Graphics.Wayland.Server (DisplayServer(..)) 11 | import Graphics.Wayland.WlRoots.Render (Renderer) 12 | 13 | data WlrCompositor 14 | 15 | foreign import ccall "wlr_compositor_create" c_compositor_create :: Ptr DisplayServer -> Ptr Renderer -> IO (Ptr WlrCompositor) 16 | 17 | compositorCreate :: DisplayServer -> Ptr Renderer -> IO (Ptr WlrCompositor) 18 | compositorCreate (DisplayServer ptr) backend = 19 | throwErrnoIfNull "compositorCreate" $ c_compositor_create ptr backend 20 | -------------------------------------------------------------------------------- /hsroots/src/Graphics/Wayland/WlRoots/DataControl.hsc: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Graphics.Wayland.WlRoots.DataControl 3 | ( DataControlManager (..) 4 | , dataControlManagerCreate 5 | ) 6 | where 7 | 8 | #define WLR_USE_UNSTABLE 9 | #include 10 | 11 | import Foreign.Ptr (Ptr) 12 | import Graphics.Wayland.Server (DisplayServer(..)) 13 | 14 | import Foreign.C.Error (throwErrnoIfNull) 15 | 16 | newtype DataControlManager = DataControlManager {unDCM :: Ptr DataControlManager} 17 | 18 | foreign import ccall safe "wlr_data_control_manager_v1_create" c_create :: Ptr DisplayServer -> IO (Ptr DataControlManager) 19 | dataControlManagerCreate :: DisplayServer -> IO DataControlManager 20 | dataControlManagerCreate (DisplayServer dsp) = fmap DataControlManager . throwErrnoIfNull "dataControlManagerCreate" $ c_create dsp 21 | -------------------------------------------------------------------------------- /hsroots/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 safe "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 | -------------------------------------------------------------------------------- /hsroots/src/Graphics/Wayland/WlRoots/Egl.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE EmptyDataDecls #-} 2 | module Graphics.Wayland.WlRoots.Egl 3 | ( EGL 4 | , eglCreate 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_, throwErrnoIfNull) 15 | 16 | data EGL 17 | 18 | 19 | foreign import ccall safe "wlr_egl_create" c_egl_create :: CInt -> Ptr a -> IO (Ptr EGL) 20 | 21 | eglCreate :: Platform -> Ptr a -> IO (Ptr EGL) 22 | eglCreate p d = let num = getPlatform p in 23 | throwErrnoIfNull "eglCreate" (c_egl_create num d) 24 | 25 | 26 | foreign import ccall safe "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 | -------------------------------------------------------------------------------- /hsroots/src/Graphics/Wayland/WlRoots/ExportDMABuf.hsc: -------------------------------------------------------------------------------- 1 | module Graphics.Wayland.WlRoots.ExportDMABuf 2 | ( ExportDMABufManager (..) 3 | , createDMAExporter 4 | ) 5 | where 6 | 7 | #define WLR_USE_UNSTABLE 8 | #include 9 | 10 | import Foreign.Ptr (Ptr) 11 | import Foreign.C.Error (throwErrnoIfNull) 12 | 13 | import Graphics.Wayland.Server (DisplayServer (..)) 14 | 15 | newtype ExportDMABufManager = ExportDMABufManager (Ptr ExportDMABufManager) 16 | 17 | foreign import ccall safe "wlr_export_dmabuf_manager_v1_create" c_create :: Ptr DisplayServer -> IO (Ptr ExportDMABufManager) 18 | 19 | createDMAExporter :: DisplayServer -> IO ExportDMABufManager 20 | createDMAExporter (DisplayServer ptr) = ExportDMABufManager <$> 21 | throwErrnoIfNull "createDMAExporter" (c_create ptr) 22 | -------------------------------------------------------------------------------- /hsroots/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 | -------------------------------------------------------------------------------- /hsroots/src/Graphics/Wayland/WlRoots/IdleInhibit.hsc: -------------------------------------------------------------------------------- 1 | module Graphics.Wayland.WlRoots.IdleInhibit 2 | ( IdleInhibitManager (..) 3 | 4 | , idleInhibitCreate 5 | , getIdleInhibitGlobal 6 | , getIdleInhibitSignal 7 | 8 | , IdleInhibitor (..) 9 | , getInhibitorDestroy 10 | , getInhibitorSurface 11 | ) 12 | where 13 | 14 | #define WLR_USE_UNSTABLE 15 | #include 16 | 17 | import Foreign.Ptr (Ptr, plusPtr) 18 | import Foreign.Storable (Storable (..)) 19 | import Foreign.C.Error (throwErrnoIfNull) 20 | 21 | import Graphics.Wayland.Server (DisplayServer(..)) 22 | import Graphics.Wayland.Signal (WlSignal) 23 | import Graphics.Wayland.Global (WlGlobal) 24 | import Graphics.Wayland.WlRoots.Surface (WlrSurface) 25 | 26 | newtype IdleInhibitManager = IdleInhibitManager { unIIM :: Ptr IdleInhibitManager} 27 | 28 | 29 | foreign import ccall "wlr_idle_inhibit_v1_create" c_create :: Ptr DisplayServer -> IO (Ptr IdleInhibitManager) 30 | 31 | idleInhibitCreate :: DisplayServer -> IO IdleInhibitManager 32 | idleInhibitCreate (DisplayServer dsp) = IdleInhibitManager <$> 33 | throwErrnoIfNull "idleInhibitCreate" (c_create dsp) 34 | 35 | getIdleInhibitGlobal :: IdleInhibitManager -> IO (Ptr WlGlobal) 36 | getIdleInhibitGlobal = 37 | #{peek struct wlr_idle_inhibit_manager_v1, global} . unIIM 38 | 39 | getIdleInhibitSignal :: IdleInhibitManager -> Ptr (WlSignal IdleInhibitor) 40 | getIdleInhibitSignal = #{ptr struct wlr_idle_inhibit_manager_v1, events.new_inhibitor} . unIIM 41 | 42 | newtype IdleInhibitor = IdleInhibitor { unII :: Ptr IdleInhibitor } deriving (Eq, Ord, Show) 43 | 44 | getInhibitorDestroy :: IdleInhibitor -> Ptr (WlSignal IdleInhibitor) 45 | getInhibitorDestroy = #{ptr struct wlr_idle_inhibitor_v1, events.destroy} . unII 46 | 47 | getInhibitorSurface :: IdleInhibitor -> IO (Ptr WlrSurface) 48 | getInhibitorSurface = #{peek struct wlr_idle_inhibitor_v1, surface} . unII 49 | -------------------------------------------------------------------------------- /hsroots/src/Graphics/Wayland/WlRoots/Input.hs-boot: -------------------------------------------------------------------------------- 1 | module Graphics.Wayland.WlRoots.Input 2 | ( InputDevice 3 | ) 4 | where 5 | 6 | data InputDevice 7 | -------------------------------------------------------------------------------- /hsroots/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 | -------------------------------------------------------------------------------- /hsroots/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 | -------------------------------------------------------------------------------- /hsroots/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 | -------------------------------------------------------------------------------- /hsroots/src/Graphics/Wayland/WlRoots/InputInhibitor.hsc: -------------------------------------------------------------------------------- 1 | module Graphics.Wayland.WlRoots.InputInhibitor 2 | ( WlrInputInhibitor (..) 3 | , createInputInhibitor 4 | 5 | , getInhibitClient 6 | , WlrInputInhibitEvents (..) 7 | , getInputInhibitorEvents 8 | , getInputInhibitGlobal 9 | ) 10 | where 11 | 12 | #define WLR_USE_UNSTABLE 13 | #include 14 | 15 | import Foreign.C.Error (throwErrnoIfNull) 16 | import Foreign.Ptr (Ptr, nullPtr, plusPtr) 17 | import Foreign.Storable (Storable (..)) 18 | 19 | import Graphics.Wayland.Server (DisplayServer (..), Client (..)) 20 | import Graphics.Wayland.Signal (WlSignal) 21 | import Graphics.Wayland.Global (WlGlobal) 22 | 23 | data WlrInputInhibitor = WlrInputInhibitor (Ptr WlrInputInhibitor) 24 | 25 | foreign import ccall safe "wlr_input_inhibit_manager_create" c_create :: Ptr DisplayServer -> IO (Ptr WlrInputInhibitor) 26 | 27 | createInputInhibitor :: DisplayServer -> IO WlrInputInhibitor 28 | createInputInhibitor (DisplayServer dsp) = WlrInputInhibitor <$> 29 | throwErrnoIfNull "createInputInhibitor" (c_create dsp) 30 | 31 | getInhibitClient :: WlrInputInhibitor -> IO (Maybe Client) 32 | getInhibitClient (WlrInputInhibitor ptr) = do 33 | ret <- #{peek struct wlr_input_inhibit_manager, active_client} ptr 34 | pure $ if ret == nullPtr 35 | then Nothing 36 | else Just $ Client ret 37 | 38 | data WlrInputInhibitEvents = WlrInputInhibitEvents 39 | { inputInhibitEventsActivate :: Ptr (WlSignal WlrInputInhibitor) 40 | , inputInhibitEventsDeactivate :: Ptr (WlSignal WlrInputInhibitor) 41 | } 42 | 43 | getInputInhibitorEvents :: WlrInputInhibitor -> WlrInputInhibitEvents 44 | getInputInhibitorEvents (WlrInputInhibitor ptr) = WlrInputInhibitEvents 45 | { inputInhibitEventsActivate = #{ptr struct wlr_input_inhibit_manager, events.activate} ptr 46 | , inputInhibitEventsDeactivate = #{ptr struct wlr_input_inhibit_manager, events.deactivate} ptr 47 | } 48 | 49 | getInputInhibitGlobal :: WlrInputInhibitor -> IO (Ptr WlGlobal) 50 | getInputInhibitGlobal (WlrInputInhibitor ptr) = 51 | #{peek struct wlr_input_inhibit_manager, global} ptr 52 | -------------------------------------------------------------------------------- /hsroots/src/Graphics/Wayland/WlRoots/LinuxDMABuf.hsc: -------------------------------------------------------------------------------- 1 | module Graphics.Wayland.WlRoots.LinuxDMABuf 2 | ( LinuxDMABuf (..) 3 | , createDMABuf 4 | ) 5 | where 6 | 7 | import Foreign.Ptr (Ptr) 8 | import Foreign.C.Error (throwErrnoIfNull) 9 | 10 | import Graphics.Wayland.Server (DisplayServer(..)) 11 | 12 | import Graphics.Wayland.WlRoots.Render (Renderer) 13 | import Graphics.Wayland.WlRoots.Backend (Backend, backendGetRenderer) 14 | 15 | newtype LinuxDMABuf = LinuxDMABuf (Ptr LinuxDMABuf) 16 | 17 | foreign import ccall safe "wlr_linux_dmabuf_v1_create" c_create :: Ptr DisplayServer -> Ptr Renderer -> IO (Ptr LinuxDMABuf) 18 | 19 | createDMABuf :: DisplayServer -> Ptr Backend -> IO LinuxDMABuf 20 | createDMABuf (DisplayServer dsp) backend = 21 | LinuxDMABuf <$> throwErrnoIfNull "creatELinuxDMABuf" (c_create dsp =<< backendGetRenderer backend) 22 | -------------------------------------------------------------------------------- /hsroots/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 safe "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 | -------------------------------------------------------------------------------- /hsroots/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 | -------------------------------------------------------------------------------- /hsroots/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 safe "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 | -------------------------------------------------------------------------------- /hsroots/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 safe "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 safe "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 safe "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 safe "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 safe "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 safe "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 | -------------------------------------------------------------------------------- /hsroots/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 | , createServerDecorationManager 11 | , getDecorationManagerEvents 12 | , getServerDecorationMode 13 | , getServerDecorationEvents 14 | ) 15 | where 16 | 17 | #define WLR_USE_UNSTABLE 18 | #include 19 | 20 | import Data.Word (Word32) 21 | import Foreign.C.Error (throwErrnoIfNull) 22 | import Foreign.Ptr (Ptr, plusPtr) 23 | import Foreign.Storable (Storable (..)) 24 | import Graphics.Wayland.Server (DisplayServer (..)) 25 | import Graphics.Wayland.Signal (WlSignal) 26 | 27 | data ServerDecorationMode 28 | = SDModeNone 29 | | SDModeClient 30 | | SDModeServer 31 | deriving (Show, Eq) 32 | 33 | sDModeToInt :: Num a => ServerDecorationMode -> a 34 | sDModeToInt SDModeNone = #{const WLR_SERVER_DECORATION_MANAGER_MODE_NONE} 35 | sDModeToInt SDModeClient = #{const WLR_SERVER_DECORATION_MANAGER_MODE_CLIENT} 36 | sDModeToInt SDModeServer = #{const WLR_SERVER_DECORATION_MANAGER_MODE_SERVER} 37 | 38 | intToSDMode :: (Num a, Eq a, Show a) => a -> ServerDecorationMode 39 | intToSDMode #{const WLR_SERVER_DECORATION_MANAGER_MODE_NONE} = SDModeNone 40 | intToSDMode #{const WLR_SERVER_DECORATION_MANAGER_MODE_CLIENT} = SDModeClient 41 | intToSDMode #{const WLR_SERVER_DECORATION_MANAGER_MODE_SERVER} = SDModeServer 42 | intToSDMode x = error $ "Found invalid ServerDeocrationMode: " ++ show x 43 | 44 | data WlrServerDecorationManager 45 | 46 | data DecorationManagerEvents = DecorationManagerEvents 47 | { decorationManagerEvtNew :: Ptr (WlSignal WlrServerDecoration) 48 | } 49 | 50 | getDecorationManagerEvents :: Ptr WlrServerDecorationManager -> DecorationManagerEvents 51 | getDecorationManagerEvents ptr = DecorationManagerEvents 52 | { decorationManagerEvtNew = #{ptr struct wlr_server_decoration_manager, events.new_decoration} ptr 53 | } 54 | 55 | 56 | foreign import ccall safe "wlr_server_decoration_manager_create" c_create :: Ptr DisplayServer -> IO (Ptr WlrServerDecorationManager) 57 | 58 | createServerDecorationManager :: DisplayServer -> IO (Ptr WlrServerDecorationManager) 59 | createServerDecorationManager (DisplayServer ptr) = 60 | throwErrnoIfNull "createServerDecorationManager" $ c_create ptr 61 | 62 | 63 | -- void wlr_server_decoration_manager_set_default_mode( 64 | -- struct wlr_server_decoration_manager *manager, uint32_t default_mode); 65 | 66 | foreign import ccall safe "wlr_server_decoration_manager_set_default_mode" c_set_default_mode :: Ptr WlrServerDecorationManager -> Word32 -> IO () 67 | 68 | setDefaultDecorationMode :: Ptr WlrServerDecorationManager -> ServerDecorationMode -> IO () 69 | setDefaultDecorationMode ptr mode = c_set_default_mode ptr $ sDModeToInt mode 70 | 71 | data WlrServerDecoration 72 | 73 | getServerDecorationMode :: Ptr WlrServerDecoration -> IO ServerDecorationMode 74 | getServerDecorationMode ptr = do 75 | val :: Word32 <- #{peek struct wlr_server_decoration, mode} ptr 76 | pure $ intToSDMode val 77 | 78 | data ServerDecorationEvents = ServerDecorationEvents 79 | { serverDecorationEvtDestroy :: Ptr (WlSignal WlrServerDecoration) 80 | , serverDecorationEvtMode :: Ptr (WlSignal WlrServerDecoration) 81 | } 82 | 83 | getServerDecorationEvents :: Ptr WlrServerDecoration -> ServerDecorationEvents 84 | getServerDecorationEvents ptr = ServerDecorationEvents 85 | { serverDecorationEvtDestroy = #{ptr struct wlr_server_decoration, events.destroy} ptr 86 | , serverDecorationEvtMode = #{ptr struct wlr_server_decoration, events.mode} ptr 87 | } 88 | 89 | -------------------------------------------------------------------------------- /hsroots/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 safe "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 | -------------------------------------------------------------------------------- /hsroots/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 safe "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 | -------------------------------------------------------------------------------- /hsroots/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 | -------------------------------------------------------------------------------- /hsroots/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 | -------------------------------------------------------------------------------- /hsroots/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 | -------------------------------------------------------------------------------- /license_helper.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | set -e -u 4 | 5 | if ! git diff --exit-code >/dev/null 6 | then 7 | echo "This script will modify your files, therefore I will refuse \ 8 | to run until you stage your changes" 9 | exit 1 10 | fi 11 | 12 | # If I need to generalise this 13 | REACH="Reach us at https:\\/\\/github.com\\/ongy\\/waymonad" 14 | PROJECT="waymonad A wayland compositor in the spirit of xmonad" 15 | YEAR=`date "+%Y"` 16 | NAME=`git config user.name` 17 | 18 | FILES=`find src -type f` 19 | 20 | for file in ${FILES} 21 | do 22 | TFILE="${file}.license_tmp" 23 | # For now we skip everything that contains a license header already. 24 | # Maybe I'll change this later (probably not in bash) 25 | if grep -q "Copyright (C)" "${file}" 26 | then 27 | continue 28 | fi 29 | 30 | cp "${file}" "${TFILE}" 31 | 32 | sed \ 33 | -e "s/{{YEAR}}/${YEAR}/" \ 34 | -e "s/{{NAME}}/${NAME}/" \ 35 | -e "s/{{PROJECT}}/${PROJECT}/" \ 36 | -e "s/{{REACH}}/${REACH}/" \ 37 | <"./.license_template" \ 38 | >"${file}" 39 | 40 | cat "${TFILE}" >> "${file}" 41 | unlink "${TFILE}" 42 | done 43 | -------------------------------------------------------------------------------- /manifest: -------------------------------------------------------------------------------- 1 | { 2 | "note": "waymonad test build", 3 | "tags": ["waymonad", "master"], 4 | "manifest": "image: debian/buster\npackages:\n - build-essential\n - git\n - python3-pip\n - pkg-config\n - libwayland-dev\n - libegl1-mesa-dev\n - wayland-protocols\n - libgles2-mesa-dev\n - libgbm-dev\n - libinput-dev\n - libxkbcommon-dev\n - libpixman-1-dev\n - libxcb-composite0-dev\n - libxcb-image0-dev\n - cabal-install\n - ghc\n - happy\n - alex\n - c2hs\n - libfuse-dev\n\nsources:\n - https://github.com/ongy/waymonad\ntasks:\n - setup: |\n pip3 install meson ninja\n git clone https://github.com/swaywm/wlroots\n (\n cd wlroots\n meson build --prefix=/usr/\n ninja -C build install\n )\n - build: |\n cd waymonad\n git submodule update --recursive --init\n touch hsroots/haskell-xkbcommon/dist\n cabal update\n cabal new-build\n" 5 | } 6 | -------------------------------------------------------------------------------- /overlay.nix: -------------------------------------------------------------------------------- 1 | _: pkgs: 2 | let 3 | sources = import ./sources.nix; 4 | in { 5 | haskellPackages = pkgs.haskellPackages.override { 6 | overrides = self: super: { 7 | hayland = self.callPackage ./hayland/hayland.nix {}; 8 | hslibinput = self.callPackage (import "${sources.libinput}/libinput.nix") {}; 9 | hsroots = self.callPackage ./hsroots/hsroots.nix {}; 10 | hsroots-new = self.callPackage ./hsroots-new/hsroots.nix {}; 11 | waymonad-scanner = self.callPackage ./waymonad-scanner/waymonad-scanner.nix {}; 12 | waymonad = self.callPackage ./waymonad.nix {}; 13 | xkbcommon = self.callPackage (import "${sources.xkbcommon}/xkbcommon.nix") {}; 14 | }; 15 | }; 16 | } 17 | -------------------------------------------------------------------------------- /protocols/background.xml: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | Copyright © 2017 Markus Ongyerth 5 | 6 | Permission is hereby granted, free of charge, to any person obtaining a copy 7 | of this software and associated documentation files (the "Software"), to deal 8 | in the Software without restriction, including without limitation the rights 9 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 10 | copies of the Software, and to permit persons to whom the Software is 11 | furnished to do so, subject to the following conditions: 12 | 13 | The above copyright notice and this permission notice shall be included in 14 | all copies or substantial portions of the Software. 15 | 16 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 17 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 18 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 19 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 20 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 21 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 22 | SOFTWARE. 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | These errors can be emitted in response to 31 | background requests. 32 | 33 | 34 | 35 | 36 | 37 | 38 | 39 | 40 | 41 | 42 | 43 | 44 | 45 | 46 | 47 | 48 | 49 | 50 | 51 | 52 | -------------------------------------------------------------------------------- /shell.nix: -------------------------------------------------------------------------------- 1 | { pkgs ? import (import ./sources.nix).nixpkgs {} }: 2 | let pkgs' = pkgs; in 3 | let 4 | pkgs = pkgs'.extend (import ./overlay.nix); 5 | in pkgs.haskellPackages.shellFor { 6 | packages = p: [ p.waymonad p.hsroots p.hayland p.waymonad-scanner p.hsroots-new ]; 7 | withHoogle = true; 8 | buildInputs = [ pkgs.cabal-install pkgs.cabal2nix pkgs.haskell-language-server ]; 9 | } 10 | -------------------------------------------------------------------------------- /sources.nix: -------------------------------------------------------------------------------- 1 | { 2 | xkbcommon = builtins.fetchTarball { 3 | url = "https://github.com/L-as/haskell-xkbcommon/archive/fbf66b30fde9a1dbda1cb591d13d55ff295d49bc.tar.gz"; 4 | sha256 = "0n93ma0cqnv89060qnay5l54id5qplf30z00bv18f6g7iq0sqcpm"; 5 | }; 6 | libinput = builtins.fetchTarball { 7 | url = "https://github.com/L-as/libinput/archive/da47b1e900ddc0e0ea68de4f36cf74064d5fe998.tar.gz"; 8 | sha256 = "06gm7jc97hj19w200gpn515yf9h1q4jmvylh9h2gjs5x6f01mwhy"; 9 | }; 10 | nixpkgs = builtins.fetchTarball { 11 | url = "https://github.com/NixOS/nixpkgs/archive/91d2ebe422fa7f3745c7ef7b73dde8dbb2a0a382.tar.gz"; 12 | sha256 = "0p5wii9gk2b2cxniq6b5hlqjvaj30hks0qfym24lnfdvb3wppz0q"; 13 | }; 14 | } 15 | -------------------------------------------------------------------------------- /src/Config/Box.hs: -------------------------------------------------------------------------------- 1 | {- 2 | waymonad A wayland compositor in the spirit of xmonad 3 | Copyright (C) 2017 Markus Ongyerth 4 | 5 | This library is free software; you can redistribute it and/or 6 | modify it under the terms of the GNU Lesser General Public 7 | License as published by the Free Software Foundation; either 8 | version 2.1 of the License, or (at your option) any later version. 9 | 10 | This library is distributed in the hope that it will be useful, 11 | but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 13 | Lesser General Public License for more details. 14 | 15 | You should have received a copy of the GNU Lesser General Public 16 | License along with this library; if not, write to the Free Software 17 | Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA 18 | 19 | Reach us at https://github.com/ongy/waymonad 20 | -} 21 | {-# LANGUAGE OverloadedStrings, ApplicativeDo #-} 22 | module Config.Box 23 | where 24 | 25 | import Config.Schema 26 | 27 | import qualified Graphics.Wayland.WlRoots.Box as R 28 | 29 | data Point a = Point 30 | { pointX :: a 31 | , pointY :: a 32 | } deriving (Eq, Show) 33 | 34 | instance HasSpec a => HasSpec (Point a) where 35 | anySpec = sectionsSpec "point" $ do 36 | x <- reqSection "x" "The x position of the point" 37 | y <- reqSection "y" "The y position of the point" 38 | 39 | pure $ Point x y 40 | 41 | asRootsPoint :: Integral a => Point a -> R.Point 42 | asRootsPoint (Point x y) = R.Point (fromIntegral x) (fromIntegral y) 43 | -------------------------------------------------------------------------------- /src/Config/Logger.hs: -------------------------------------------------------------------------------- 1 | {- 2 | waymonad A wayland compositor in the spirit of xmonad 3 | Copyright (C) 2017 Markus Ongyerth 4 | 5 | This library is free software; you can redistribute it and/or 6 | modify it under the terms of the GNU Lesser General Public 7 | License as published by the Free Software Foundation; either 8 | version 2.1 of the License, or (at your option) any later version. 9 | 10 | This library is distributed in the hope that it will be useful, 11 | but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 13 | Lesser General Public License for more details. 14 | 15 | You should have received a copy of the GNU Lesser General Public 16 | License along with this library; if not, write to the Free Software 17 | Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA 18 | 19 | Reach us at https://github.com/ongy/waymonad 20 | -} 21 | {-# LANGUAGE OverloadedStrings #-} 22 | {-# LANGUAGE ApplicativeDo #-} 23 | {-# OPTIONS_GHC -fno-warn-orphans #-} 24 | module Config.Logger 25 | ( prioritySpec 26 | , loggerSpec 27 | , modifyLoggerConfig 28 | ) 29 | where 30 | 31 | import Config.Schema 32 | import Data.Functor.Alt (()) 33 | import Data.Maybe (fromMaybe) 34 | import Data.Text (Text) 35 | 36 | import Waymonad.Types.Logger (LogPriority(..), WayLoggers (..), Logger (..)) 37 | import Waymonad.Main 38 | 39 | prioritySpec :: ValueSpec LogPriority 40 | prioritySpec = 41 | Error <$ atomSpec "Error" 42 | Warn <$ atomSpec "Warn" 43 | Info <$ atomSpec "Info" 44 | Debug <$ atomSpec "Debug" 45 | Trace <$ atomSpec "Trace" 46 | 47 | instance HasSpec LogPriority where 48 | anySpec = prioritySpec 49 | 50 | loggerSection :: Text -> Text -> SectionsSpec Logger 51 | loggerSection name desc = flip Logger name . fromMaybe Warn <$> optSection name desc 52 | 53 | loggerSpec :: ValueSpec WayLoggers 54 | loggerSpec = sectionsSpec "loggers" (WayLoggers 55 | <$> loggerSection "Output" "Output Logger" 56 | <*> loggerSection "WS" "WS Logger" 57 | <*> loggerSection "Focus" "Focus Logger" 58 | <*> loggerSection "Xdg" "Xdg Logger" 59 | <*> loggerSection "X11" "X11 Logger" 60 | <*> loggerSection "Keybinds""Keybinds Logger" 61 | <*> loggerSection "Spawner" "Spawner Logger" 62 | <*> loggerSection "Layout" "Layout Logger" 63 | <*> loggerSection "Render" "Render Logger" 64 | ) 65 | 66 | instance HasSpec WayLoggers where 67 | anySpec = loggerSpec 68 | 69 | modifyLoggerConfig :: Maybe WayLoggers -> WayUserConf vs ws -> WayUserConf vs ws 70 | modifyLoggerConfig Nothing conf = conf 71 | modifyLoggerConfig (Just loggers) conf = 72 | conf { wayUserconfLoggers = Just loggers } 73 | -------------------------------------------------------------------------------- /src/Fuse/Extensible.hs: -------------------------------------------------------------------------------- 1 | {- 2 | waymonad A wayland compositor in the spirit of xmonad 3 | Copyright (C) 2018 Markus Ongyerth 4 | 5 | This library is free software; you can redistribute it and/or 6 | modify it under the terms of the GNU Lesser General Public 7 | License as published by the Free Software Foundation; either 8 | version 2.1 of the License, or (at your option) any later version. 9 | 10 | This library is distributed in the hope that it will be useful, 11 | but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 13 | Lesser General Public License for more details. 14 | 15 | You should have received a copy of the GNU Lesser General Public 16 | License along with this library; if not, write to the Free Software 17 | Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA 18 | 19 | Reach us at https://github.com/ongy/waymonad 20 | -} 21 | {-# LANGUAGE TupleSections #-} 22 | {-# LANGUAGE ScopedTypeVariables #-} 23 | module Fuse.Extensible 24 | ( extensibleDir 25 | ) 26 | where 27 | 28 | import Data.Maybe (catMaybes) 29 | import Data.Typeable (Typeable) 30 | import Data.Text (Text) 31 | 32 | import Waymonad.IPC 33 | import Waymonad.Types (Way) 34 | -- import Waymonad.Utility.Base 35 | 36 | import Fuse.Common 37 | 38 | import qualified Data.Map as M 39 | import qualified Data.Text as T 40 | 41 | makeEntry :: (Typeable vs, Typeable ws) => IPCEntry vs ws -> Way vs ws (Maybe (Entry vs ws)) 42 | makeEntry e@(IPCEntry _ _ rCheck wCheck) = do 43 | isR <- rCheck 44 | isW <- wCheck 45 | pure $ case isR || isW of 46 | False -> Nothing 47 | True -> Just . FileEntry $ ipcFile (getEntryReadFun e) (if isW then getEntryWriteFun e else Nothing) 48 | 49 | 50 | makeGroup :: forall vs ws. (Typeable vs, Typeable ws) => IPCGroup vs ws -> Entry vs ws 51 | makeGroup (IPCGroup xs) = DirEntry $ enumeratingDir (M.fromList . catMaybes <$> mapM handleElem xs) 52 | where handleElem :: (Text, Either (IPCGroup vs ws) (IPCEntry vs ws)) -> Way vs ws (Maybe (String, Entry vs ws)) 53 | handleElem (name, Left grp) = pure $ Just (T.unpack name, makeGroup grp) 54 | handleElem (name, Right entry) = fmap (T.unpack name,) <$> makeEntry entry 55 | 56 | extensibleDir :: (Typeable vs, Typeable ws) => IPCGroup vs ws -> Entry vs ws 57 | extensibleDir = makeGroup 58 | -------------------------------------------------------------------------------- /src/Fuse/Handler.hs: -------------------------------------------------------------------------------- 1 | {- 2 | waymonad A wayland compositor in the spirit of xmonad 3 | Copyright (C) 2018 Markus Ongyerth 4 | 5 | This library is free software; you can redistribute it and/or 6 | modify it under the terms of the GNU Lesser General Public 7 | License as published by the Free Software Foundation; either 8 | version 2.1 of the License, or (at your option) any later version. 9 | 10 | This library is distributed in the hope that it will be useful, 11 | but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 13 | Lesser General Public License for more details. 14 | 15 | You should have received a copy of the GNU Lesser General Public 16 | License along with this library; if not, write to the Free Software 17 | Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA 18 | 19 | Reach us at https://github.com/ongy/waymonad 20 | -} 21 | module Fuse.Handler 22 | where 23 | 24 | 25 | -------------------------------------------------------------------------------- /src/Fuse/Shells.hs: -------------------------------------------------------------------------------- 1 | {- 2 | waymonad A wayland compositor in the spirit of xmonad 3 | Copyright (C) 2018 Markus Ongyerth 4 | 5 | This library is free software; you can redistribute it and/or 6 | modify it under the terms of the GNU Lesser General Public 7 | License as published by the Free Software Foundation; either 8 | version 2.1 of the License, or (at your option) any later version. 9 | 10 | This library is distributed in the hope that it will be useful, 11 | but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 13 | Lesser General Public License for more details. 14 | 15 | You should have received a copy of the GNU Lesser General Public 16 | License along with this library; if not, write to the Free Software 17 | Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA 18 | 19 | Reach us at https://github.com/ongy/waymonad 20 | -} 21 | {-# LANGUAGE OverloadedStrings #-} 22 | {-# LANGUAGE TupleSections #-} 23 | module Fuse.Shells 24 | where 25 | 26 | import Control.Monad (forM) 27 | import Data.Map (Map) 28 | import Data.Maybe (fromMaybe) 29 | import Foreign.C.Error (eINVAL) 30 | 31 | import Fuse.Common 32 | import Waymonad.View (getViewTitle, getViewAppId) 33 | import Waymonad.ViewSet (FocusCore, WSTag) 34 | import Waymonad 35 | import Waymonad.Types 36 | import Waymonad.Shells 37 | 38 | import qualified Data.Map as M 39 | import qualified Data.Set as S 40 | import qualified Data.Text as T 41 | 42 | makeViewFile :: WayShell vs a -> Way vs a (Entry vs a) 43 | makeViewFile shell = do 44 | views <- shellViews shell 45 | tmp <- forM (S.toList views) $ \view -> do 46 | title <-fromMaybe "" <$> getViewTitle view 47 | appId <- fromMaybe "" <$> getViewAppId view 48 | pure $ title `T.append` " : " `T.append` appId 49 | 50 | let content = T.intercalate "\n" tmp 51 | pure $ FileEntry . textFile $ pure content 52 | 53 | makeShellDir :: (FocusCore vs a, WSTag a) => WayShell vs a -> Way vs a (Entry vs a) 54 | makeShellDir shell = do 55 | let active = ("state", FileEntry $ textRWFile 56 | (T.pack . show <$> shellActive shell) 57 | (\txt -> case txt of 58 | "enable" -> Right <$> startShell shell 59 | "disable" -> Right <$> stopShell shell 60 | _ -> pure $ Left eINVAL 61 | ) 62 | ) 63 | viewsFile <- ("views", ) <$> makeViewFile shell 64 | 65 | pure $ DirEntry $ simpleDir $ M.fromList $ [active, viewsFile] 66 | 67 | enumerateShells :: (FocusCore vs a, WSTag a) => Way vs a (Map String (Entry vs a)) 68 | enumerateShells = do 69 | shells <- wayCoreShells <$> getState 70 | 71 | fmap M.fromList . forM shells $ \shell -> do 72 | entry <- makeShellDir shell 73 | name <- shellName shell 74 | pure (T.unpack $ name, entry) 75 | 76 | shellsDir :: (FocusCore vs a, WSTag a) => Entry vs a 77 | shellsDir = DirEntry $ enumeratingDir enumerateShells 78 | -------------------------------------------------------------------------------- /src/Fuse/Workspaces.hs: -------------------------------------------------------------------------------- 1 | {- 2 | waymonad A wayland compositor in the spirit of xmonad 3 | Copyright (C) 2018 Markus Ongyerth 4 | 5 | This library is free software; you can redistribute it and/or 6 | modify it under the terms of the GNU Lesser General Public 7 | License as published by the Free Software Foundation; either 8 | version 2.1 of the License, or (at your option) any later version. 9 | 10 | This library is distributed in the hope that it will be useful, 11 | but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 13 | Lesser General Public License for more details. 14 | 15 | You should have received a copy of the GNU Lesser General Public 16 | License along with this library; if not, write to the Free Software 17 | Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA 18 | 19 | Reach us at https://github.com/ongy/waymonad 20 | -} 21 | {-# LANGUAGE TupleSections #-} 22 | {-# LANGUAGE OverloadedStrings #-} 23 | module Fuse.Workspaces 24 | ( workspaceDir 25 | ) 26 | where 27 | 28 | import Control.Monad (forM) 29 | import Control.Monad.IO.Class (liftIO) 30 | import Data.Map (Map) 31 | import Data.Maybe (fromMaybe) 32 | 33 | import Waymonad.View (getViewTitle, getViewAppId) 34 | import Waymonad.ViewSet (WSTag (..){-, LayoutClass (..), GenericLayout (..)-}, FocusCore) 35 | import Waymonad.Types (Way, Output (outputName)) 36 | import Waymonad.Utility.Focus (getWorkspaceOutputs) 37 | import Waymonad.Utility.ViewSet (getWorkspaces, getWorkspaceViews) 38 | 39 | import Fuse.Common 40 | 41 | import qualified Data.Map as M 42 | import qualified Data.Text as T 43 | 44 | makeViewDir :: (FocusCore vs a, WSTag a) => a -> Way vs a (Maybe (Entry vs a)) 45 | makeViewDir ws = do 46 | views <- getWorkspaceViews ws 47 | case views of 48 | [] -> pure Nothing 49 | _ -> Just <$> do 50 | tmp <- forM views $ \view -> liftIO $ do 51 | title <-fromMaybe "" <$> getViewTitle view 52 | appId <- fromMaybe "" <$> getViewAppId view 53 | pure $ title `T.append` " : " `T.append` appId 54 | 55 | let content = T.intercalate "\n" tmp 56 | pure $ FileEntry . textFile $ pure content 57 | 58 | makeOutputDir :: (FocusCore vs a, WSTag a) => a -> Way vs a (Maybe (Entry vs a)) 59 | makeOutputDir ws = do 60 | outs <- getWorkspaceOutputs ws 61 | case outs of 62 | [] -> pure Nothing 63 | xs -> pure . Just . DirEntry . simpleDir . M.fromList . flip fmap xs $ \out -> 64 | let name = T.unpack $ outputName out 65 | in (name, SymlinkEntry . pure $ "../../../outputs/" ++ name) 66 | 67 | makeWorkspaceDir :: (FocusCore vs a, WSTag a) => a -> Way vs a (Entry vs a) 68 | makeWorkspaceDir ws = do 69 | let layout = 70 | [{- ("layout", FileEntry $ textFile $ do 71 | Workspace (GenericLayout l) _ <- getWorkspace ws 72 | pure $ description l) 73 | , ("current", FileEntry $ textFile $ do 74 | Workspace (GenericLayout l) _ <- getWorkspace ws 75 | pure $ currentDesc l)-} 76 | ] 77 | 78 | outs <- makeOutputDir ws 79 | let outDir = maybe id ((:) . ("outputs",)) outs 80 | 81 | views <- makeViewDir ws 82 | let viewDir = maybe id ((:) . ("views", )) views 83 | 84 | pure $ DirEntry $ simpleDir $ M.fromList $ viewDir . outDir $ layout 85 | 86 | enumerateWSS :: (FocusCore vs a, WSTag a) => Way vs a (Map String (Entry vs a)) 87 | enumerateWSS = do 88 | wss <- getWorkspaces 89 | M.fromList <$> mapM (\ws -> (T.unpack $ getName ws,) <$> makeWorkspaceDir ws) wss 90 | 91 | workspaceDir :: (FocusCore vs a, WSTag a) => Entry vs a 92 | workspaceDir = DirEntry $ enumeratingDir enumerateWSS 93 | -------------------------------------------------------------------------------- /src/Waymonad/Actions/Spawn/X11.hs: -------------------------------------------------------------------------------- 1 | {- 2 | waymonad A wayland compositor in the spirit of xmonad 3 | Copyright (C) 2018 Markus Ongyerth 4 | 5 | This library is free software; you can redistribute it and/or 6 | modify it under the terms of the GNU Lesser General Public 7 | License as published by the Free Software Foundation; either 8 | version 2.1 of the License, or (at your option) any later version. 9 | 10 | This library is distributed in the hope that it will be useful, 11 | but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 13 | Lesser General Public License for more details. 14 | 15 | You should have received a copy of the GNU Lesser General Public 16 | License along with this library; if not, write to the Free Software 17 | Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA 18 | 19 | Reach us at https://github.com/ongy/waymonad 20 | -} 21 | module Waymonad.Actions.Spawn.X11 22 | ( manageX11SpawnOn 23 | , spawnX11On 24 | ) 25 | where 26 | 27 | import Control.DeepSeq (NFData (..), force) 28 | import Control.Monad.IO.Class (liftIO) 29 | import Data.List (lookup) 30 | import Data.Typeable (Typeable) 31 | import System.Posix.Types (ProcessID) 32 | import System.Posix.Process (forkProcess, executeFile) 33 | 34 | import Waymonad.Shells.XWayland (xwayGetPid) 35 | import Waymonad.View (getViewInner) 36 | import Waymonad.ViewSet (WSTag) 37 | import Waymonad.Extensible (ExtensionClass (..)) 38 | import Waymonad.Managehook (Managehook, query, liftWay, InsertAction (InsertInto)) 39 | import Waymonad.Utility.Extensible (getEState , modifyEState) 40 | import Waymonad.Utility.Base (doJust, whenJust) 41 | import Waymonad.Types (Way) 42 | 43 | newtype PidT = PidT ProcessID deriving (Eq) 44 | instance NFData PidT where rnf = flip seq () 45 | 46 | newtype X11Spawner ws = X11Spawner { spawnPids :: [(PidT, ws)] } deriving Typeable 47 | 48 | instance Typeable ws => ExtensionClass (X11Spawner ws) where 49 | initialValue = X11Spawner [] 50 | 51 | modifySpawner :: (NFData ws, Typeable ws) => ([(PidT, ws)] -> [(PidT, ws)]) -> Way vs ws () 52 | modifySpawner fun = modifyEState (X11Spawner . force . fun . spawnPids) 53 | 54 | manageX11SpawnOn :: (NFData ws, WSTag ws) => Managehook vs ws 55 | manageX11SpawnOn = do 56 | view <- query 57 | liftWay $ doJust (getViewInner view) $ \xway -> 58 | doJust (fmap PidT <$> xwayGetPid xway) $ \pid -> do 59 | X11Spawner pids <- getEState 60 | whenJust (lookup pid pids) $ \ws -> do 61 | modifySpawner (filter ((/=) pid . fst)) 62 | pure $ InsertInto ws 63 | 64 | execChild :: String -> [String] -> IO a 65 | execChild name args = executeFile name True args Nothing 66 | 67 | spawnX11On :: (NFData ws, Typeable ws) => ws -> String -> [String] -> Way vs ws () 68 | spawnX11On ws name args = do 69 | pid <- liftIO $ forkProcess $ execChild name args 70 | modifySpawner ((:) (PidT pid, ws) . take 19) 71 | -------------------------------------------------------------------------------- /src/Waymonad/Actions/Startup/Environment.hs: -------------------------------------------------------------------------------- 1 | {- 2 | waymonad A wayland compositor in the spirit of xmonad 3 | Copyright (C) 2018 Markus Ongyerth 4 | 5 | This library is free software; you can redistribute it and/or 6 | modify it under the terms of the GNU Lesser General Public 7 | License as published by the Free Software Foundation; either 8 | version 2.1 of the License, or (at your option) any later version. 9 | 10 | This library is distributed in the hope that it will be useful, 11 | but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 13 | Lesser General Public License for more details. 14 | 15 | You should have received a copy of the GNU Lesser General Public 16 | License along with this library; if not, write to the Free Software 17 | Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA 18 | 19 | Reach us at https://github.com/ongy/waymonad 20 | -} 21 | {-| 22 | Module : Startup.Environment 23 | Description : Allows to set environment variables on startup. 24 | Maintainer : ongy 25 | Stability : testing 26 | Portability : Linux 27 | -} 28 | module Waymonad.Actions.Startup.Environment 29 | where 30 | 31 | import Control.Monad.IO.Class (liftIO) 32 | import System.Environment (setEnv) 33 | 34 | import Graphics.Wayland.Server (DisplayServer) 35 | 36 | import Waymonad.Start (Bracketed (..)) 37 | 38 | {- | Set environment variables on startup. 39 | 40 | This happens early enough to be used by wlroots/backend stuff. 41 | 42 | @ 43 | envBracket [(\"PULSE_SERVER\", "zelda.ongy")] 44 | @ 45 | -} 46 | envBracket :: [(String, String)] -> Bracketed vs DisplayServer ws 47 | envBracket xs = Bracketed 48 | (\_ -> liftIO (mapM_ (uncurry setEnv) xs)) 49 | (\_ -> pure ()) 50 | -------------------------------------------------------------------------------- /src/Waymonad/Actions/Startup/Generic.hs: -------------------------------------------------------------------------------- 1 | {- 2 | waymonad A wayland compositor in the spirit of xmonad 3 | Copyright (C) 2018 Markus Ongyerth 4 | 5 | This library is free software; you can redistribute it and/or 6 | modify it under the terms of the GNU Lesser General Public 7 | License as published by the Free Software Foundation; either 8 | version 2.1 of the License, or (at your option) any later version. 9 | 10 | This library is distributed in the hope that it will be useful, 11 | but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 13 | Lesser General Public License for more details. 14 | 15 | You should have received a copy of the GNU Lesser General Public 16 | License along with this library; if not, write to the Free Software 17 | Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA 18 | 19 | Reach us at https://github.com/ongy/waymonad 20 | -} 21 | {-| 22 | Module : Startup.Generic 23 | Description : Allows to run any Way action when the compositor is done starting up 24 | Maintainer : ongy 25 | Stability : testing 26 | Portability : Linux 27 | -} 28 | module Waymonad.Actions.Startup.Generic 29 | ( getStartupBracket 30 | ) 31 | where 32 | 33 | import Control.Monad (void) 34 | import Control.Monad.IO.Class (liftIO) 35 | 36 | import Graphics.Wayland.Server (DisplayServer, eventLoopAddIdle, displayGetEventLoop) 37 | 38 | import Waymonad.Start (Bracketed (..)) 39 | import Waymonad (unliftWay) 40 | import Waymonad.Types (Way) 41 | 42 | {- | Run a Way action when the compositor is started up. 43 | 44 | @ 45 | getStartupBracket (spawn "alacritty") 46 | @ 47 | -} 48 | getStartupBracket :: Way vs a () -> Bracketed vs DisplayServer a 49 | getStartupBracket act = Bracketed (\dsp -> do 50 | evtLoop <- liftIO $ displayGetEventLoop dsp 51 | cb <- unliftWay act 52 | void . liftIO $ eventLoopAddIdle evtLoop cb 53 | ) (const $ pure ()) 54 | -------------------------------------------------------------------------------- /src/Waymonad/Extensible.hs: -------------------------------------------------------------------------------- 1 | {- 2 | waymonad A wayland compositor in the spirit of xmonad 3 | Copyright (C) 2017 Markus Ongyerth 4 | 5 | This library is free software; you can redistribute it and/or 6 | modify it under the terms of the GNU Lesser General Public 7 | License as published by the Free Software Foundation; either 8 | version 2.1 of the License, or (at your option) any later version. 9 | 10 | This library is distributed in the hope that it will be useful, 11 | but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 13 | Lesser General Public License for more details. 14 | 15 | You should have received a copy of the GNU Lesser General Public 16 | License along with this library; if not, write to the Free Software 17 | Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA 18 | 19 | Reach us at https://github.com/ongy/waymonad 20 | -} 21 | {-# LANGUAGE ExistentialQuantification #-} 22 | {-# LANGUAGE ScopedTypeVariables #-} 23 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 24 | module Waymonad.Extensible 25 | ( StateMap 26 | , ExtensionClass (..) 27 | 28 | , getValue 29 | , setValue 30 | , modifyValue 31 | ) 32 | where 33 | 34 | import Data.Map (Map) 35 | import Data.Maybe (fromMaybe) 36 | import Data.Semigroup (Semigroup) 37 | import Data.Typeable (Typeable, typeOf, cast) 38 | 39 | import qualified Data.Map.Strict as M 40 | 41 | newtype StateMap = StateMap (Map String StateExtension) 42 | deriving (Semigroup, Monoid) 43 | 44 | class Typeable a => ExtensionClass a where 45 | initialValue :: a 46 | 47 | data StateExtension = forall a. ExtensionClass a => StateExtension a 48 | 49 | getName :: Typeable a => a -> String 50 | getName = show . typeOf 51 | 52 | getValue :: forall a. ExtensionClass a => StateMap -> a 53 | getValue (StateMap state) = fromMaybe initialValue $ do 54 | (StateExtension x) <- M.lookup (getName (undefined :: a)) state 55 | cast x 56 | 57 | setValue :: ExtensionClass a => a -> StateMap -> StateMap 58 | setValue val (StateMap state) = StateMap $ M.insert (getName val) (StateExtension val) state 59 | 60 | modifyValue :: ExtensionClass a => (a -> a) -> StateMap -> StateMap 61 | modifyValue fun state = setValue (fun $ getValue state) state 62 | 63 | instance Typeable a => ExtensionClass (Maybe a) where 64 | initialValue = Nothing 65 | -------------------------------------------------------------------------------- /src/Waymonad/Hooks/EnterLeave.hs: -------------------------------------------------------------------------------- 1 | {- 2 | waymonad A wayland compositor in the spirit of xmonad 3 | Copyright (C) 2018 Markus Ongyerth 4 | 5 | This library is free software; you can redistribute it and/or 6 | modify it under the terms of the GNU Lesser General Public 7 | License as published by the Free Software Foundation; either 8 | version 2.1 of the License, or (at your option) any later version. 9 | 10 | This library is distributed in the hope that it will be useful, 11 | but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 13 | Lesser General Public License for more details. 14 | 15 | You should have received a copy of the GNU Lesser General Public 16 | License along with this library; if not, write to the Free Software 17 | Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA 18 | 19 | Reach us at https://github.com/ongy/waymonad 20 | -} 21 | module Waymonad.Hooks.EnterLeave 22 | ( enterLeaveHook 23 | ) 24 | where 25 | 26 | import Control.Monad (forM_) 27 | import Control.Monad.IO.Class (liftIO) 28 | 29 | import Graphics.Wayland.WlRoots.Surface (surfaceSendLeave, surfaceSendEnter) 30 | 31 | import Waymonad.Utility.Base (whenJust, doJust) 32 | import Waymonad.View (getViewSurface) 33 | import Waymonad.ViewSet (WSTag, FocusCore (..)) 34 | import Waymonad.Utility.Focus (OutputMappingEvent (..)) 35 | import Waymonad.Types (Way, Output (..)) 36 | import Waymonad.Utility.ViewSet (withViewSet) 37 | 38 | import qualified Data.Set as S 39 | 40 | sendLeaves :: (FocusCore vs a, WSTag a) => Output -> a -> Way vs a () 41 | sendLeaves output ws = do 42 | zipper <- withViewSet $ \_ vs -> _getViews vs ws 43 | liftIO $ forM_ (fmap snd $ S.toList zipper) $ \view -> 44 | doJust (getViewSurface view) (flip surfaceSendLeave $ outputRoots output) 45 | 46 | sendEnters :: (FocusCore vs a, WSTag a) => Output -> a -> Way vs a () 47 | sendEnters output ws = do 48 | zipper <- withViewSet $ \_ vs -> _getViews vs ws 49 | liftIO $ forM_ (fmap snd $ S.toList zipper) $ \view -> 50 | doJust (getViewSurface view) (flip surfaceSendEnter $ outputRoots output) 51 | 52 | enterLeaveHook 53 | :: (FocusCore vs a, WSTag a) 54 | => OutputMappingEvent a 55 | -> Way vs a () 56 | enterLeaveHook evt = do 57 | whenJust (outputMappingEvtPre evt) (sendLeaves $ outputMappingEvtOutput evt) 58 | whenJust (outputMappingEvtCur evt) (sendEnters $ outputMappingEvtOutput evt) 59 | -------------------------------------------------------------------------------- /src/Waymonad/Hooks/FocusFollowPointer.hs: -------------------------------------------------------------------------------- 1 | {- 2 | waymonad A wayland compositor in the spirit of xmonad 3 | Copyright (C) 2018 Markus Ongyerth 4 | 5 | This library is free software; you can redistribute it and/or 6 | modify it under the terms of the GNU Lesser General Public 7 | License as published by the Free Software Foundation; either 8 | version 2.1 of the License, or (at your option) any later version. 9 | 10 | This library is distributed in the hope that it will be useful, 11 | but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 13 | Lesser General Public License for more details. 14 | 15 | You should have received a copy of the GNU Lesser General Public 16 | License along with this library; if not, write to the Free Software 17 | Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA 18 | 19 | Reach us at https://github.com/ongy/waymonad 20 | -} 21 | module Waymonad.Hooks.FocusFollowPointer 22 | where 23 | 24 | import Waymonad.Types (SeatFocusChange (..), Way, EvtCause (..), SeatEvent (..)) 25 | import Waymonad.View (doFocusView) 26 | import Waymonad.ViewSet (FocusCore, WSTag) 27 | 28 | focusFollowPointer :: (WSTag ws, FocusCore vs ws) => SeatFocusChange -> Way vs ws () 29 | focusFollowPointer (SeatFocusChange SeatPointer Intentional seat _ (Just view)) = 30 | doFocusView view seat 31 | focusFollowPointer _ = pure () 32 | -------------------------------------------------------------------------------- /src/Waymonad/Hooks/OutputAdd.hs: -------------------------------------------------------------------------------- 1 | {- 2 | waymonad A wayland compositor in the spirit of xmonad 3 | Copyright (C) 2017 Markus Ongyerth 4 | 5 | This library is free software; you can redistribute it and/or 6 | modify it under the terms of the GNU Lesser General Public 7 | License as published by the Free Software Foundation; either 8 | version 2.1 of the License, or (at your option) any later version. 9 | 10 | This library is distributed in the hope that it will be useful, 11 | but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 13 | Lesser General Public License for more details. 14 | 15 | You should have received a copy of the GNU Lesser General Public 16 | License along with this library; if not, write to the Free Software 17 | Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA 18 | 19 | Reach us at https://github.com/ongy/waymonad 20 | -} 21 | {-# LANGUAGE ScopedTypeVariables #-} 22 | module Waymonad.Hooks.OutputAdd 23 | ( outputAddHook 24 | ) 25 | where 26 | 27 | import Control.Monad (when, void) 28 | import Control.Monad.IO.Class (liftIO) 29 | import Data.IORef (readIORef) 30 | import Data.Traversable (for) 31 | import Data.List ((\\)) 32 | 33 | import Graphics.Wayland.WlRoots.Box (WlrBox (..), Point (..)) 34 | 35 | import Waymonad (Way, WayBindingState (..), getState) 36 | import Waymonad.Output (Output, getOutputBox) 37 | import Waymonad.Types (OutputEvent (..), EvtCause (SideEffect)) 38 | import Waymonad.Utility.Base (These (..)) 39 | import Waymonad.Utility.Base (doJust) 40 | import Waymonad.Utility.Focus (setOutputWorkspace) 41 | import Waymonad.Utility.Mapping (setSeatOutput) 42 | import Waymonad.Utility.Pointer (sendSeatTo) 43 | import Waymonad.Utility.Timing 44 | import Waymonad.ViewSet (WSTag, FocusCore) 45 | 46 | attachFreeWS :: (FocusCore vs a, WSTag a) => Output -> Way vs a () 47 | attachFreeWS out = do 48 | taken <- fmap (map fst) <$> liftIO . readIORef . wayBindingMapping =<< getState 49 | wss <- wayUserWorkspaces <$> getState 50 | 51 | case wss \\ taken of 52 | (x:_) -> setOutputWorkspace x out 53 | [] -> pure () 54 | 55 | attachFreeSeats :: (FocusCore vs ws, WSTag ws) => Output -> Way vs ws () 56 | attachFreeSeats out = do 57 | state <- getState 58 | seats <- liftIO . readIORef . wayBindingSeats $ state 59 | mapped <- liftIO . readIORef . wayBindingCurrent $ state 60 | 61 | let free = seats \\ map fst mapped 62 | void . for free $ \seat -> do 63 | doJust (getOutputBox out) $ \(WlrBox x y w h) -> 64 | sendSeatTo (Point (x + w `div` 2) (y + h `div` 2)) seat 65 | setSeatOutput seat (These out out) SideEffect 66 | 67 | 68 | outputAddHook :: (FocusCore vs a, WSTag a) => OutputEvent -> Way vs a () 69 | outputAddHook (OutputEvent out) = do 70 | time :: Word <- getSeconds <$> getBasedTime 71 | when (time < 300) $ do 72 | attachFreeWS out 73 | attachFreeSeats out 74 | -------------------------------------------------------------------------------- /src/Waymonad/Hooks/ScaleHook.hs: -------------------------------------------------------------------------------- 1 | {- 2 | waymonad A wayland compositor in the spirit of xmonad 3 | Copyright (C) 2018 Markus Ongyerth 4 | 5 | This library is free software; you can redistribute it and/or 6 | modify it under the terms of the GNU Lesser General Public 7 | License as published by the Free Software Foundation; either 8 | version 2.1 of the License, or (at your option) any later version. 9 | 10 | This library is distributed in the hope that it will be useful, 11 | but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 13 | Lesser General Public License for more details. 14 | 15 | You should have received a copy of the GNU Lesser General Public 16 | License along with this library; if not, write to the Free Software 17 | Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA 18 | 19 | Reach us at https://github.com/ongy/waymonad 20 | -} 21 | module Waymonad.Hooks.ScaleHook 22 | ( wsScaleHook 23 | ) 24 | where 25 | 26 | import Control.Monad (forM_) 27 | import Control.Monad.IO.Class (liftIO) 28 | import Foreign.Ptr (Ptr) 29 | 30 | import Graphics.Wayland.WlRoots.Output (WlrOutput) 31 | import Graphics.Wayland.WlRoots.Surface 32 | ( WlrSurface 33 | , surfaceSendLeave 34 | , surfaceSendEnter 35 | ) 36 | 37 | import Waymonad.Utility.Base (doJust) 38 | import Waymonad.View (View, getViewSurface) 39 | import Waymonad.ViewSet (WSTag, FocusCore) 40 | import Waymonad.Types (ViewWSChange (..)) 41 | import Waymonad.Utility.Focus (getWorkspaceOutputs) 42 | import Waymonad (Way) 43 | import Waymonad.Output (Output (..)) 44 | 45 | enactEvent :: WSTag a => (View -> Output -> Way vs a ()) -> View -> a -> Way vs a () 46 | enactEvent fun view ws = do 47 | outs <- getWorkspaceOutputs ws 48 | forM_ outs (fun view) 49 | 50 | sendScaleEvent :: (Ptr WlrSurface -> Ptr WlrOutput -> IO ()) -> View -> Output -> Way vs a () 51 | sendScaleEvent fun view output = liftIO $ 52 | doJust (getViewSurface view) (flip fun $ outputRoots output) 53 | 54 | 55 | wsScaleHook :: (FocusCore vs a, WSTag a) => ViewWSChange a -> Way vs a () 56 | wsScaleHook (WSEnter v ws) = enactEvent (sendScaleEvent surfaceSendEnter) v ws 57 | wsScaleHook (WSExit v ws) = enactEvent (sendScaleEvent surfaceSendLeave) v ws 58 | -------------------------------------------------------------------------------- /src/Waymonad/Hooks/SeatMapping.hs: -------------------------------------------------------------------------------- 1 | {- 2 | waymonad A wayland compositor in the spirit of xmonad 3 | Copyright (C) 2017 Markus Ongyerth 4 | 5 | This library is free software; you can redistribute it and/or 6 | modify it under the terms of the GNU Lesser General Public 7 | License as published by the Free Software Foundation; either 8 | version 2.1 of the License, or (at your option) any later version. 9 | 10 | This library is distributed in the hope that it will be useful, 11 | but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 13 | Lesser General Public License for more details. 14 | 15 | You should have received a copy of the GNU Lesser General Public 16 | License along with this library; if not, write to the Free Software 17 | Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA 18 | 19 | Reach us at https://github.com/ongy/waymonad 20 | -} 21 | {-# LANGUAGE ScopedTypeVariables #-} 22 | module Waymonad.Hooks.SeatMapping 23 | ( mappingChangeEvt 24 | , outputChangeEvt 25 | , wsChangeLogHook 26 | ) 27 | where 28 | 29 | import Control.Monad (when, join, forM_) 30 | 31 | import Waymonad.Output (Output) 32 | import Waymonad.ViewSet (WSTag) 33 | import Waymonad (getState) 34 | import Waymonad.Types 35 | import Waymonad.Utility.Mapping (getOutputKeyboards, getOutputPointers, getOutputWS) 36 | import Waymonad.Utility.Log 37 | 38 | checkOutput :: WSTag a 39 | => Maybe Output -> Maybe Output 40 | -> (Maybe a -> Maybe a -> SeatWSChange a) 41 | -> Way vs a () 42 | checkOutput pre cur con = do 43 | preWS <- join <$> traverse getOutputWS pre 44 | curWS <- join <$> traverse getOutputWS cur 45 | when (preWS /= curWS) $ do 46 | hook <- wayHooksSeatWSChange . wayCoreHooks <$> getState 47 | hook $ con preWS curWS 48 | 49 | outputChangeEvt :: WSTag a => SeatOutputChange -> Way vs a () 50 | outputChangeEvt (SeatOutputChange SeatPointer _ seat pre cur) = 51 | checkOutput pre cur $ SeatWSChange SeatKeyboard SideEffect seat 52 | outputChangeEvt (SeatOutputChange SeatKeyboard _ seat pre cur) = 53 | checkOutput pre cur $ SeatWSChange SeatKeyboard SideEffect seat 54 | 55 | mappingChangeEvt :: WSTag a => OutputMappingEvent a -> Way vs a () 56 | mappingChangeEvt (OutputMappingEvent out pre cur) = do 57 | keys <- getOutputKeyboards out 58 | points <- getOutputPointers out 59 | 60 | hook <- wayHooksSeatWSChange . wayCoreHooks <$> getState 61 | forM_ points $ \point -> hook $ SeatWSChange SeatPointer SideEffect point pre cur 62 | forM_ keys $ \key -> hook $ SeatWSChange SeatKeyboard SideEffect key pre cur 63 | 64 | wsChangeLogHook :: forall ws vs. WSTag ws => SeatWSChange ws -> Way vs ws () 65 | wsChangeLogHook evt = logPrint loggerWS Debug evt 66 | -------------------------------------------------------------------------------- /src/Waymonad/IdleDPMS.hs: -------------------------------------------------------------------------------- 1 | {- 2 | waymonad A wayland compositor in the spirit of xmonad 3 | Copyright (C) 2018 Markus Ongyerth 4 | 5 | This library is free software; you can redistribute it and/or 6 | modify it under the terms of the GNU Lesser General Public 7 | License as published by the Free Software Foundation; either 8 | version 2.1 of the License, or (at your option) any later version. 9 | 10 | This library is distributed in the hope that it will be useful, 11 | but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 13 | Lesser General Public License for more details. 14 | 15 | You should have received a copy of the GNU Lesser General Public 16 | License along with this library; if not, write to the Free Software 17 | Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA 18 | 19 | Reach us at https://github.com/ongy/waymonad 20 | -} 21 | module Waymonad.IdleDPMS 22 | ( idleDPMSHandler 23 | ) 24 | where 25 | 26 | import Control.Monad (filterM, when) 27 | import Control.Monad.IO.Class (liftIO) 28 | import Data.Proxy (Proxy (..)) 29 | import Data.IORef (readIORef) 30 | import Data.Semigroup ((<>)) 31 | import Data.Set (Set) 32 | 33 | import Graphics.Wayland.WlRoots.Output (outputEnable, outputDisable) 34 | 35 | import Waymonad (getEvent) 36 | import Waymonad.Extensible 37 | import Waymonad.IdleManager (isIdle, IdleEvent (..)) 38 | import Waymonad.Protocols.IdleInhibit (getInhibitedOutputs, IdleInhibitChange) 39 | import Waymonad.Types (Output (..), Way, SomeEvent) 40 | import Waymonad.Utility.Extensible 41 | import Waymonad.Utility.Mapping (getOutputs) 42 | 43 | import qualified Data.Set as S 44 | 45 | newtype IdleDPMSOuts = IdleDPMSOuts { unIDO :: Set Output } 46 | 47 | instance ExtensionClass IdleDPMSOuts where 48 | initialValue = IdleDPMSOuts mempty 49 | 50 | relevantOuts :: Way vs ws (Set Output) 51 | relevantOuts = do 52 | outs <- getOutputs 53 | fmap S.fromList $ filterM (liftIO . readIORef . outputActive) outs 54 | 55 | -- fst: Newly DPMS off 56 | -- snd: Newly DPMS on 57 | getOutputChanges :: Way vs ws (Set Output, Set Output) 58 | getOutputChanges = do 59 | outs <- relevantOuts 60 | current <- unIDO <$> getEState 61 | inhibited <- getInhibitedOutputs 62 | let turnOn = current `S.intersection` inhibited 63 | let turnOff = outs `S.difference` (current `S.union` inhibited) 64 | pure (turnOff, turnOn) 65 | 66 | 67 | setNewState :: Way vs ws () 68 | setNewState = do 69 | (turnOff, turnOn) <- getOutputChanges 70 | 71 | liftIO $ do 72 | mapM_ (outputDisable . outputRoots) $ S.toList turnOff 73 | mapM_ (outputEnable . outputRoots) $ S.toList turnOn 74 | 75 | modifyEState (IdleDPMSOuts . flip S.difference turnOn . 76 | S.union turnOff . unIDO) 77 | 78 | unsetDPMS :: Way vs ws () 79 | unsetDPMS = do 80 | current <- unIDO <$> getEState 81 | mapM_ (liftIO . outputEnable . outputRoots) $ S.toList current 82 | setEState $ IdleDPMSOuts mempty 83 | 84 | handleInhibitChange :: Maybe IdleInhibitChange -> Way vs ws () 85 | handleInhibitChange Nothing = pure () 86 | handleInhibitChange _ = do 87 | doDPMS <- isIdle (Proxy :: Proxy IdleEvent) 88 | when doDPMS setNewState 89 | 90 | handleIdleChange :: Maybe IdleEvent -> Way vs ws () 91 | handleIdleChange Nothing = pure () 92 | handleIdleChange (Just IdleStop) = unsetDPMS 93 | handleIdleChange (Just IdleStart) = setNewState 94 | 95 | idleDPMSHandler :: SomeEvent -> Way vs ws () 96 | idleDPMSHandler e = 97 | handleIdleChange (getEvent e) <> handleInhibitChange (getEvent e) 98 | -------------------------------------------------------------------------------- /src/Waymonad/Input.hs-boot: -------------------------------------------------------------------------------- 1 | {- 2 | waymonad A wayland compositor in the spirit of xmonad 3 | Copyright (C) 2017 Markus Ongyerth 4 | 5 | This library is free software; you can redistribute it and/or 6 | modify it under the terms of the GNU Lesser General Public 7 | License as published by the Free Software Foundation; either 8 | version 2.1 of the License, or (at your option) any later version. 9 | 10 | This library is distributed in the hope that it will be useful, 11 | but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 13 | Lesser General Public License for more details. 14 | 15 | You should have received a copy of the GNU Lesser General Public 16 | License along with this library; if not, write to the Free Software 17 | Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA 18 | 19 | Reach us at https://github.com/ongy/waymonad 20 | -} 21 | module Waymonad.Input 22 | ( Input (..) 23 | ) 24 | where 25 | 26 | import Data.IORef (IORef) 27 | import Data.Map (Map) 28 | import Data.Set (Set) 29 | import Data.Text (Text) 30 | import Foreign.Ptr (Ptr) 31 | 32 | import Graphics.Wayland.WlRoots.XCursorManager (WlrXCursorManager) 33 | import Graphics.Wayland.WlRoots.Input (InputDevice) 34 | import Graphics.Wayland.Signal (ListenerToken) 35 | 36 | import Waymonad.Input.Cursor.Type (Cursor) 37 | import {-# SOURCE #-} Waymonad.Input.Seat (Seat) 38 | 39 | data SeatFoo = SeatFoo 40 | { fooXCursorManager :: Ptr WlrXCursorManager 41 | , fooCursor :: Cursor 42 | , fooSeat :: Seat 43 | , fooImageToken :: ListenerToken 44 | } 45 | 46 | data Input = Input 47 | { inputDevices :: IORef (Set (Ptr InputDevice)) 48 | , inputFooMap :: IORef (Map Text SeatFoo) 49 | , inputAddToken :: [ListenerToken] 50 | } 51 | -------------------------------------------------------------------------------- /src/Waymonad/Input/Cursor.hs-boot: -------------------------------------------------------------------------------- 1 | {- 2 | waymonad A wayland compositor in the spirit of xmonad 3 | Copyright (C) 2017 Markus Ongyerth 4 | 5 | This library is free software; you can redistribute it and/or 6 | modify it under the terms of the GNU Lesser General Public 7 | License as published by the Free Software Foundation; either 8 | version 2.1 of the License, or (at your option) any later version. 9 | 10 | This library is distributed in the hope that it will be useful, 11 | but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 13 | Lesser General Public License for more details. 14 | 15 | You should have received a copy of the GNU Lesser General Public 16 | License along with this library; if not, write to the Free Software 17 | Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA 18 | 19 | Reach us at https://github.com/ongy/waymonad 20 | -} 21 | module Waymonad.Input.Cursor 22 | where 23 | 24 | import Data.Word (Word32) 25 | 26 | import Waymonad.ViewSet (FocusCore, WSTag) 27 | import Waymonad.Input.Cursor.Type 28 | import Waymonad.Types 29 | 30 | updateFocus :: (FocusCore vs ws, WSTag ws) 31 | => Cursor 32 | -> Word32 33 | -> Way vs ws () 34 | 35 | forcePosition :: (FocusCore vs ws, WSTag ws) 36 | => Cursor 37 | -> (Double, Double) 38 | -> Word32 39 | -> Way vs ws () 40 | -------------------------------------------------------------------------------- /src/Waymonad/Input/Cursor/Type.hs: -------------------------------------------------------------------------------- 1 | {- 2 | waymonad A wayland compositor in the spirit of xmonad 3 | Copyright (C) 2017 Markus Ongyerth 4 | 5 | This library is free software; you can redistribute it and/or 6 | modify it under the terms of the GNU Lesser General Public 7 | License as published by the Free Software Foundation; either 8 | version 2.1 of the License, or (at your option) any later version. 9 | 10 | This library is distributed in the hope that it will be useful, 11 | but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 13 | Lesser General Public License for more details. 14 | 15 | You should have received a copy of the GNU Lesser General Public 16 | License along with this library; if not, write to the Free Software 17 | Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA 18 | 19 | Reach us at https://github.com/ongy/waymonad 20 | -} 21 | module Waymonad.Input.Cursor.Type 22 | where 23 | 24 | import Data.Functor.Identity (Identity) 25 | import Data.IORef (IORef) 26 | import Data.Int (Int32) 27 | import Data.Word (Word32) 28 | import Foreign.Ptr (Ptr) 29 | 30 | import Graphics.Wayland.Signal (ListenerToken) 31 | import Graphics.Wayland.WlRoots.Cursor (WlrCursor) 32 | import Graphics.Wayland.WlRoots.Input (InputDevice) 33 | import Graphics.Wayland.WlRoots.Input.Buttons (ButtonState) 34 | import Graphics.Wayland.WlRoots.Input.Pointer (AxisSource, AxisOrientation) 35 | 36 | data CursorMapping c = CursorMapping 37 | { cursorMappingButton :: c (Cursor -> Word32 -> Word32 -> ButtonState -> IO ()) 38 | , cursorMappingMotion :: c (Cursor -> Word32 -> Ptr InputDevice -> Double -> Double -> IO ()) 39 | , cursorMappingMotionAbs :: c (Cursor -> Word32 -> Ptr InputDevice -> Double -> Double -> IO ()) 40 | , cursorMappingAxis :: c (Cursor -> Word32 -> AxisSource -> AxisOrientation -> Double -> Int32 -> IO ()) 41 | } 42 | 43 | data Cursor = Cursor 44 | { cursorRoots :: Ptr WlrCursor 45 | , cursorTokens :: IORef [ListenerToken] -- ^ Should be immutable, but we don't have to overdo the unsafePerformIO readIORef, do we? 46 | , cursorOutput :: IORef Int 47 | , cursorMapping :: IORef (CursorMapping Identity) 48 | } 49 | -------------------------------------------------------------------------------- /src/Waymonad/Input/Seat.hs-boot: -------------------------------------------------------------------------------- 1 | {- 2 | waymonad A wayland compositor in the spirit of xmonad 3 | Copyright (C) 2018 Markus Ongyerth 4 | 5 | This library is free software; you can redistribute it and/or 6 | modify it under the terms of the GNU Lesser General Public 7 | License as published by the Free Software Foundation; either 8 | version 2.1 of the License, or (at your option) any later version. 9 | 10 | This library is distributed in the hope that it will be useful, 11 | but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 13 | Lesser General Public License for more details. 14 | 15 | You should have received a copy of the GNU Lesser General Public 16 | License along with this library; if not, write to the Free Software 17 | Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA 18 | 19 | Reach us at https://github.com/ongy/waymonad 20 | -} 21 | module Waymonad.Input.Seat 22 | ( Seat 23 | , getPointerFocus 24 | , getKeyboardFocus 25 | ) 26 | where 27 | 28 | import Control.Monad.IO.Class (MonadIO) 29 | import Waymonad.Types.Core (Seat, View) 30 | 31 | getPointerFocus :: MonadIO m => Seat -> m (Maybe View) 32 | getKeyboardFocus :: MonadIO m => Seat -> m (Maybe View) 33 | -------------------------------------------------------------------------------- /src/Waymonad/Input/Tablet/Types.hs: -------------------------------------------------------------------------------- 1 | {- 2 | waymonad A wayland compositor in the spirit of xmonad 3 | Copyright (C) 2018 Markus Ongyerth 4 | 5 | This library is free software; you can redistribute it and/or 6 | modify it under the terms of the GNU Lesser General Public 7 | License as published by the Free Software Foundation; either 8 | version 2.1 of the License, or (at your option) any later version. 9 | 10 | This library is distributed in the hope that it will be useful, 11 | but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 13 | Lesser General Public License for more details. 14 | 15 | You should have received a copy of the GNU Lesser General Public 16 | License along with this library; if not, write to the Free Software 17 | Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA 18 | 19 | Reach us at https://github.com/ongy/waymonad 20 | -} 21 | {-# LANGUAGE ScopedTypeVariables #-} 22 | module Waymonad.Input.Tablet.Types 23 | where 24 | 25 | import Data.IORef (IORef) 26 | import Graphics.Wayland.Signal (removeListener, ListenerToken) 27 | 28 | import qualified Graphics.Wayland.WlRoots.Tabletv2 as R 29 | 30 | data Tablet = Tablet 31 | { tabRoots :: R.Tabletv2 32 | , tabTockens :: [ListenerToken] 33 | } 34 | 35 | data TabletTool = TabletTool 36 | { toolRoots :: R.TabletToolv2 37 | , toolTockens :: [ListenerToken] 38 | , toolOutputToken :: IORef Int 39 | } 40 | 41 | instance Eq Tablet where 42 | Tablet { tabRoots = l } == Tablet { tabRoots = r } = l == r 43 | 44 | instance Ord Tablet where 45 | Tablet { tabRoots = l } `compare` Tablet { tabRoots = r } = l `compare` r 46 | 47 | data TabletPad = TabletPad 48 | { padRoots :: R.TabletPadv2 49 | , padTockens :: [ListenerToken] 50 | , padTablet :: IORef (Maybe Tablet) 51 | } 52 | 53 | instance Eq TabletPad where 54 | TabletPad { padRoots = l } == TabletPad { padRoots = r } = l == r 55 | 56 | instance Ord TabletPad where 57 | TabletPad { padRoots = l } `compare` TabletPad { padRoots = r } = l `compare` r 58 | -------------------------------------------------------------------------------- /src/Waymonad/Layout/Choose.hs: -------------------------------------------------------------------------------- 1 | {- 2 | waymonad A wayland compositor in the spirit of xmonad 3 | Copyright (C) 2017 Markus Ongyerth 4 | 5 | This library is free software; you can redistribute it and/or 6 | modify it under the terms of the GNU Lesser General Public 7 | License as published by the Free Software Foundation; either 8 | version 2.1 of the License, or (at your option) any later version. 9 | 10 | This library is distributed in the hope that it will be useful, 11 | but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 13 | Lesser General Public License for more details. 14 | 15 | You should have received a copy of the GNU Lesser General Public 16 | License along with this library; if not, write to the Free Software 17 | Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA 18 | 19 | Reach us at https://github.com/ongy/waymonad 20 | -} 21 | {-# LANGUAGE OverloadedStrings #-} 22 | {-# LANGUAGE InstanceSigs #-} 23 | {-# LANGUAGE FlexibleInstances #-} 24 | {-# LANGUAGE MultiParamTypeClasses #-} 25 | module Waymonad.Layout.Choose 26 | ( Choose 27 | , NextLayout (FirstLayout, NextLayout) 28 | , (|||) 29 | ) 30 | where 31 | 32 | import Control.Applicative ((<|>)) 33 | import Data.Maybe (fromMaybe) 34 | import Data.Text (Text) 35 | 36 | import Waymonad.Types.Core (Seat) 37 | import Waymonad.ViewSet 38 | 39 | import qualified Data.Text as T 40 | 41 | (|||) :: l -> r -> Choose l r 42 | (|||) = Choose L 43 | infixr 5 ||| 44 | 45 | 46 | data LR = L | R deriving (Eq, Show) 47 | 48 | data Choose l r = Choose LR l r deriving (Eq, Show) 49 | 50 | data NextLayout = FirstLayout | NextLayout | NoWrap deriving (Eq, Show) 51 | 52 | instance Message NextLayout 53 | 54 | 55 | handle :: LayoutClass l => NextLayout -> Maybe Seat -> l -> Maybe l 56 | handle m s l = handleMessage l s (SomeMessage m) 57 | 58 | choose :: Choose l r -> Maybe l -> Maybe r -> Maybe (Choose l r) 59 | choose _ Nothing Nothing = Nothing 60 | choose (Choose lr l r) nl nr = Just $ Choose lr (fromMaybe l nl) (fromMaybe r nr) 61 | 62 | handleNext :: (LayoutClass l, LayoutClass r) => NextLayout -> Maybe Seat -> Choose l r -> Maybe (Choose l r) 63 | handleNext FirstLayout s (Choose _ l r) = choose (Choose L l r) (handle FirstLayout s l) (Just r) 64 | handleNext NoWrap s (Choose L l r) = case handle NoWrap s l of 65 | Just nl -> Just (Choose L nl r) 66 | Nothing -> choose (Choose R l r) (Just l) (handle FirstLayout s r) 67 | handleNext NoWrap s (Choose R l r) = Choose R l <$> handle NoWrap s r 68 | handleNext NextLayout s c = handle NoWrap s c <|> handle FirstLayout s c 69 | 70 | instance (LayoutClass l, LayoutClass r) => LayoutClass (Choose l r) where 71 | handleMessage :: Choose l r -> Maybe Seat -> SomeMessage -> Maybe (Choose l r) 72 | handleMessage c s m 73 | | Just msg <- getMessage m = handleNext msg s c 74 | | otherwise = case c of 75 | Choose L l _ -> choose c (handleMessage l s m) Nothing 76 | Choose R _ r -> choose c Nothing (handleMessage r s m) 77 | --TODO: Implement this broadcast 78 | broadcastMessage :: Choose l r -> SomeMessage -> Maybe (Choose l r) 79 | broadcastMessage l m = handleMessage l Nothing m 80 | description :: Choose l r -> Text 81 | description (Choose _ l r) = description l `T.append` " ||| " `T.append` description r 82 | currentDesc :: Choose l r -> Text 83 | currentDesc (Choose L l _) = currentDesc l 84 | currentDesc (Choose R _ r) = currentDesc r 85 | 86 | 87 | instance (GenericLayoutClass l vs ws, GenericLayoutClass r vs ws) => GenericLayoutClass (Choose l r) vs ws where 88 | pureLayout (Choose L l _) vs ws b = pureLayout l vs ws b 89 | pureLayout (Choose R _ r) vs ws b = pureLayout r vs ws b 90 | -------------------------------------------------------------------------------- /src/Waymonad/Layout/Full.hs: -------------------------------------------------------------------------------- 1 | {- 2 | waymonad A wayland compositor in the spirit of xmonad 3 | Copyright (C) 2017 Markus Ongyerth 4 | 5 | This library is free software; you can redistribute it and/or 6 | modify it under the terms of the GNU Lesser General Public 7 | License as published by the Free Software Foundation; either 8 | version 2.1 of the License, or (at your option) any later version. 9 | 10 | This library is distributed in the hope that it will be useful, 11 | but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 13 | Lesser General Public License for more details. 14 | 15 | You should have received a copy of the GNU Lesser General Public 16 | License along with this library; if not, write to the Free Software 17 | Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA 18 | 19 | Reach us at https://github.com/ongy/waymonad 20 | -} 21 | {-# LANGUAGE OverloadedStrings #-} 22 | {-# LANGUAGE TypeSynonymInstances #-} 23 | {-# LANGUAGE FlexibleInstances #-} 24 | {-# LANGUAGE MultiParamTypeClasses #-} 25 | module Waymonad.Layout.Full 26 | where 27 | 28 | import Control.Applicative ((<|>)) 29 | import Waymonad.ViewSet 30 | 31 | import Waymonad.Types (SSDPrio (..)) 32 | 33 | data Full = Full 34 | 35 | instance LayoutClass Full where 36 | description _ = "Full" 37 | handleMessage _ _ _ = Nothing 38 | broadcastMessage _ _ = Nothing 39 | 40 | instance FocusCore vs ws => GenericLayoutClass Full vs ws where 41 | pureLayout _ vs ws box = case _getFocused vs ws Nothing <|> getFirst vs ws of 42 | Nothing -> [] 43 | Just v -> [(v, NoSSD mempty, box)] 44 | -------------------------------------------------------------------------------- /src/Waymonad/Layout/Ratio.hs: -------------------------------------------------------------------------------- 1 | {- 2 | waymonad A wayland compositor in the spirit of xmonad 3 | Copyright (C) 2018 Markus Ongyerth 4 | 5 | This library is free software; you can redistribute it and/or 6 | modify it under the terms of the GNU Lesser General Public 7 | License as published by the Free Software Foundation; either 8 | version 2.1 of the License, or (at your option) any later version. 9 | 10 | This library is distributed in the hope that it will be useful, 11 | but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 13 | Lesser General Public License for more details. 14 | 15 | You should have received a copy of the GNU Lesser General Public 16 | License along with this library; if not, write to the Free Software 17 | Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA 18 | 19 | Reach us at https://github.com/ongy/waymonad 20 | -} 21 | module Waymonad.Layout.Ratio 22 | where 23 | 24 | import Waymonad.ViewSet (Message) 25 | 26 | -- | Share message type for Layouts that are based on some kind of ratio 27 | data ChangeRatio 28 | = IncreaseRatio Double -- ^Increase the ratio 29 | | DecreaseRatio Double -- ^Decrease the ratio 30 | deriving (Show, Eq) 31 | 32 | instance Message ChangeRatio 33 | -------------------------------------------------------------------------------- /src/Waymonad/Layout/Spiral.hs: -------------------------------------------------------------------------------- 1 | {- 2 | waymonad A wayland compositor in the spirit of xmonad 3 | Copyright (C) 2017 Markus Ongyerth 4 | 5 | This library is free software; you can redistribute it and/or 6 | modify it under the terms of the GNU Lesser General Public 7 | License as published by the Free Software Foundation; either 8 | version 2.1 of the License, or (at your option) any later version. 9 | 10 | This library is distributed in the hope that it will be useful, 11 | but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 13 | Lesser General Public License for more details. 14 | 15 | You should have received a copy of the GNU Lesser General Public 16 | License along with this library; if not, write to the Free Software 17 | Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA 18 | 19 | Reach us at https://github.com/ongy/waymonad 20 | -} 21 | {-# LANGUAGE OverloadedStrings #-} 22 | {-# LANGUAGE InstanceSigs #-} 23 | {-# LANGUAGE FlexibleInstances #-} 24 | {-# LANGUAGE MultiParamTypeClasses #-} 25 | module Waymonad.Layout.Spiral 26 | where 27 | 28 | import Data.Set (Set) 29 | import Data.Text (Text) 30 | 31 | import Graphics.Wayland.WlRoots.Box (WlrBox (..)) 32 | 33 | import Waymonad.Layout.Ratio 34 | import Waymonad.ViewSet 35 | import Waymonad.Types 36 | import Waymonad.Types.Core (Seat) 37 | 38 | data Spiral = Spiral Double 39 | 40 | doLayout :: Spiral -> Int -> WlrBox -> [(Set Seat, c)] -> [(c, SSDPrio, WlrBox)] 41 | doLayout _ _ _ [] = [] 42 | doLayout _ _ b [(f, x)] = [(x, NoSSD f, b)] 43 | doLayout s@(Spiral r) 0 b@WlrBox{boxWidth = width, boxX = x} ((f, z):zs) = 44 | let used = floor $ fromIntegral width * r 45 | in (z, NoSSD f, b {boxWidth = used}) : doLayout s 1 b {boxWidth = width - used, boxX = x + used} zs 46 | doLayout s@(Spiral r) 1 b@WlrBox{boxHeight = height, boxY = y} ((f, z):zs) = 47 | let used = floor $ fromIntegral height * r 48 | in (z, NoSSD f, b {boxHeight = used}) : doLayout s 2 b {boxHeight = height - used, boxY = y + used} zs 49 | doLayout s@(Spiral r) 2 b@WlrBox{boxWidth = width, boxX = x} ((f, z):zs) = 50 | let used = floor $ fromIntegral width * r 51 | in (z, NoSSD f, b {boxWidth = used, boxX = x + width - used}) : doLayout s 3 b {boxWidth = width - used} zs 52 | doLayout s@(Spiral r) _ b@WlrBox{boxHeight = height, boxY = y} ((f, z):zs) = 53 | let used = floor $ fromIntegral height * r 54 | in (z, NoSSD f, b {boxHeight = used, boxY = y + height - used}) : doLayout s 0 b {boxHeight = height - used} zs 55 | 56 | instance LayoutClass Spiral where 57 | handleMessage :: Spiral -> Maybe Seat -> SomeMessage -> Maybe Spiral 58 | handleMessage (Spiral val) _ m = case getMessage m of 59 | Just (IncreaseRatio x) -> Just . Spiral $ min 1 $ val + x 60 | Just (DecreaseRatio x) -> Just . Spiral $ max 0 $ val - x 61 | _ -> Nothing 62 | broadcastMessage :: Spiral -> SomeMessage -> Maybe Spiral 63 | broadcastMessage l m = handleMessage l Nothing m 64 | description :: Spiral -> Text 65 | description _ = "Spiral" 66 | 67 | instance ListLike vs ws => GenericLayoutClass Spiral vs ws where 68 | pureLayout s vs ws box = doLayout s 0 box $ _asList vs ws 69 | -------------------------------------------------------------------------------- /src/Waymonad/Layout/Tall.hs: -------------------------------------------------------------------------------- 1 | {- 2 | waymonad A wayland compositor in the spirit of xmonad 3 | Copyright (C) 2017 Markus Ongyerth 4 | 5 | This library is free software; you can redistribute it and/or 6 | modify it under the terms of the GNU Lesser General Public 7 | License as published by the Free Software Foundation; either 8 | version 2.1 of the License, or (at your option) any later version. 9 | 10 | This library is distributed in the hope that it will be useful, 11 | but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 13 | Lesser General Public License for more details. 14 | 15 | You should have received a copy of the GNU Lesser General Public 16 | License along with this library; if not, write to the Free Software 17 | Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA 18 | 19 | Reach us at https://github.com/ongy/waymonad 20 | -} 21 | {-# LANGUAGE OverloadedStrings #-} 22 | {-# LANGUAGE TypeSynonymInstances #-} 23 | {-# LANGUAGE FlexibleInstances #-} 24 | {-# LANGUAGE MultiParamTypeClasses #-} 25 | {-# LANGUAGE LambdaCase #-} 26 | module Waymonad.Layout.Tall 27 | where 28 | 29 | import Data.Set (Set) 30 | 31 | import Graphics.Wayland.WlRoots.Box (WlrBox(..)) 32 | 33 | import Waymonad.Layout.Ratio 34 | import Waymonad.Layout.Vertical (layoutVertical) 35 | import Waymonad.Types (SSDPrio (NoSSD)) 36 | import Waymonad.Types.Core (Seat, View) 37 | import Waymonad.ViewSet 38 | 39 | newtype Tall = Tall Double 40 | 41 | instance LayoutClass Tall where 42 | description _ = "Tall" 43 | handleMessage (Tall val) _ m = case getMessage m of 44 | Just (IncreaseRatio x) -> Just . Tall $ val + x 45 | Just (DecreaseRatio x) -> Just . Tall $ val - x 46 | _ -> Nothing 47 | broadcastMessage (Tall val) m = case getMessage m of 48 | Just (IncreaseRatio x) -> Just . Tall $ val + x 49 | Just (DecreaseRatio x) -> Just . Tall $ val - x 50 | _ -> Nothing 51 | 52 | instance ListLike vs ws => GenericLayoutClass Tall vs ws where 53 | pureLayout (Tall ratio) vs ws box = 54 | layoutTall ratio box (_asList vs ws) 55 | 56 | layoutTall :: Double -> WlrBox -> [(Set Seat, View)] -> [(View, SSDPrio, WlrBox)] 57 | layoutTall _ box [(s, x)] = [(x, NoSSD s, box)] 58 | layoutTall ratio box (x:xs) = 59 | let unclipped = floor $ fromIntegral (boxWidth box) * ratio 60 | width = min (boxWidth box - 10) . max 10 $ unclipped 61 | master = (snd x, NoSSD $ fst x, box { boxWidth = width }) 62 | ibox = box 63 | { boxWidth = boxWidth box - width 64 | , boxX = boxX box + width 65 | } 66 | in master : layoutVertical ibox xs 67 | layoutTall _ _ _ = [] 68 | -------------------------------------------------------------------------------- /src/Waymonad/Layout/TwoPane.hs: -------------------------------------------------------------------------------- 1 | {- 2 | waymonad A wayland compositor in the spirit of xmonad 3 | Copyright (C) 2017 Markus Ongyerth 4 | 5 | This library is free software; you can redistribute it and/or 6 | modify it under the terms of the GNU Lesser General Public 7 | License as published by the Free Software Foundation; either 8 | version 2.1 of the License, or (at your option) any later version. 9 | 10 | This library is distributed in the hope that it will be useful, 11 | but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 13 | Lesser General Public License for more details. 14 | 15 | You should have received a copy of the GNU Lesser General Public 16 | License along with this library; if not, write to the Free Software 17 | Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA 18 | 19 | Reach us at https://github.com/ongy/waymonad 20 | -} 21 | {-# LANGUAGE OverloadedStrings #-} 22 | {-# LANGUAGE TypeSynonymInstances #-} 23 | {-# LANGUAGE FlexibleInstances #-} 24 | {-# LANGUAGE MultiParamTypeClasses #-} 25 | module Waymonad.Layout.TwoPane 26 | where 27 | 28 | import Waymonad.Layout.Ratio 29 | import Waymonad.Layout.Tall 30 | import Waymonad.ViewSet 31 | 32 | import qualified Data.Set as S 33 | 34 | data TwoPane = TwoPane Double 35 | 36 | instance LayoutClass TwoPane where 37 | description _ = "TwoPane" 38 | handleMessage (TwoPane val) _ m = case getMessage m of 39 | Just (IncreaseRatio x) -> Just . TwoPane $ val + x 40 | Just (DecreaseRatio x) -> Just . TwoPane $ val - x 41 | _ -> Nothing 42 | broadcastMessage (TwoPane val) m = case getMessage m of 43 | Just (IncreaseRatio x) -> Just . TwoPane $ val + x 44 | Just (DecreaseRatio x) -> Just . TwoPane $ val - x 45 | _ -> Nothing 46 | 47 | instance ListLike vs ws => GenericLayoutClass TwoPane vs ws where 48 | pureLayout (TwoPane ratio) vs ws box = case _asList vs ws of 49 | (x:ys@(y:_))-> 50 | let focused = filter (not . S.null . fst) ys 51 | xFocused = not . S.null . fst $ x 52 | master = if xFocused || length focused < 2 then x else head focused 53 | secondary = case focused of 54 | [] -> y 55 | (z:[]) -> z 56 | (z:z2:_) -> if xFocused then z else z2 57 | 58 | in layoutTall ratio box [master, secondary] 59 | zs -> layoutTall ratio box zs 60 | -------------------------------------------------------------------------------- /src/Waymonad/Layout/Vertical.hs: -------------------------------------------------------------------------------- 1 | {- 2 | waymonad A wayland compositor in the spirit of xmonad 3 | Copyright (C) 2018 Markus Ongyerth 4 | 5 | This library is free software; you can redistribute it and/or 6 | modify it under the terms of the GNU Lesser General Public 7 | License as published by the Free Software Foundation; either 8 | version 2.1 of the License, or (at your option) any later version. 9 | 10 | This library is distributed in the hope that it will be useful, 11 | but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 13 | Lesser General Public License for more details. 14 | 15 | You should have received a copy of the GNU Lesser General Public 16 | License along with this library; if not, write to the Free Software 17 | Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA 18 | 19 | Reach us at https://github.com/ongy/waymonad 20 | -} 21 | {-# LANGUAGE OverloadedStrings #-} 22 | {-# LANGUAGE TypeSynonymInstances #-} 23 | {-# LANGUAGE FlexibleInstances #-} 24 | {-# LANGUAGE MultiParamTypeClasses #-} 25 | {-# LANGUAGE LambdaCase #-} 26 | module Waymonad.Layout.Vertical 27 | where 28 | 29 | import Data.Set (Set) 30 | 31 | import Graphics.Wayland.WlRoots.Box (WlrBox(..)) 32 | 33 | import Waymonad.ViewSet 34 | import Waymonad.Types (SSDPrio (NoSSD)) 35 | import Waymonad.Types.Core (Seat, View) 36 | 37 | data Vertical = Vertical 38 | 39 | instance LayoutClass Vertical where 40 | description _ = "Vertical" 41 | handleMessage _ _ _ = Nothing 42 | broadcastMessage _ _ = Nothing 43 | 44 | instance ListLike vs ws => GenericLayoutClass Vertical vs ws where 45 | pureLayout _ vs ws box = layoutVertical box (_asList vs ws) 46 | 47 | layoutVertical :: WlrBox -> [(Set Seat, View)] -> [(View, SSDPrio, WlrBox)] 48 | layoutVertical box xs = 49 | let slaves = zip xs [0 ..] 50 | num = length xs 51 | height = boxHeight box `div` num 52 | ibox i = box 53 | { boxHeight = height 54 | , boxY = boxY box + i * height 55 | } 56 | in map (\((s, v), i) -> (v, NoSSD s, ibox i)) slaves 57 | -------------------------------------------------------------------------------- /src/Waymonad/Output/Core.hs: -------------------------------------------------------------------------------- 1 | {- 2 | waymonad A wayland compositor in the spirit of xmonad 3 | Copyright (C) 2018 Markus Ongyerth 4 | 5 | This library is free software; you can redistribute it and/or 6 | modify it under the terms of the GNU Lesser General Public 7 | License as published by the Free Software Foundation; either 8 | version 2.1 of the License, or (at your option) any later version. 9 | 10 | This library is distributed in the hope that it will be useful, 11 | but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 13 | Lesser General Public License for more details. 14 | 15 | You should have received a copy of the GNU Lesser General Public 16 | License along with this library; if not, write to the Free Software 17 | Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA 18 | 19 | Reach us at https://github.com/ongy/waymonad 20 | -} 21 | module Waymonad.Output.Core 22 | where 23 | 24 | import Control.Monad.IO.Class (MonadIO, liftIO) 25 | 26 | import Graphics.Pixman 27 | import Graphics.Wayland.WlRoots.Util.Region 28 | import Graphics.Wayland.WlRoots.Box (WlrBox (..)) 29 | import Graphics.Wayland.WlRoots.Output 30 | ( setOutputNeedsFrame 31 | , scheduleOutputFrame 32 | , getEffectiveBox 33 | , getOutputScale 34 | ) 35 | 36 | import Waymonad.Utility.Base (ptrToInt) 37 | import Waymonad.Types (Output (..)) 38 | 39 | setOutputDirty :: MonadIO m => Output -> m () 40 | setOutputDirty out = liftIO $ setOutputNeedsFrame (outputRoots out) True 41 | 42 | getOutputId :: Output -> Int 43 | getOutputId = ptrToInt . outputRoots 44 | 45 | outApplyDamage :: MonadIO m => Output -> Maybe PixmanRegion32 -> m () 46 | outApplyDamage o@Output {outputRoots = roots} Nothing = liftIO $ do 47 | WlrBox _ _ w h <- getEffectiveBox roots 48 | withRegion $ \reg -> do 49 | resetRegion reg . Just $ WlrBox 0 0 w h 50 | outApplyDamage o (Just reg) 51 | outApplyDamage Output {outputRoots = roots, outputDamage = damage} (Just reg) = liftIO $ do 52 | setOutputNeedsFrame roots True 53 | 54 | outputScale <- getOutputScale roots 55 | scaleRegion reg outputScale 56 | pixmanRegionUnion damage reg 57 | 58 | scheduleOutputFrame roots 59 | -------------------------------------------------------------------------------- /src/Waymonad/Protocols/DMAExport.hs: -------------------------------------------------------------------------------- 1 | module Waymonad.Protocols.DMAExport (getDMAExporterBracket) 2 | where 3 | 4 | 5 | import Control.Monad.IO.Class (liftIO) 6 | import Foreign.Ptr (Ptr) 7 | 8 | import Graphics.Wayland.Server (DisplayServer(..)) 9 | import Graphics.Wayland.WlRoots.ExportDMABuf (createDMAExporter) 10 | 11 | import Waymonad.Start (Bracketed (..)) 12 | 13 | getDMAExporterBracket :: Bracketed vs DisplayServer a 14 | getDMAExporterBracket = Bracketed (liftIO . createDMAExporter) (const $ pure ()) 15 | 16 | -------------------------------------------------------------------------------- /src/Waymonad/Protocols/DataControl.hs: -------------------------------------------------------------------------------- 1 | {- 2 | waymonad A wayland compositor in the spirit of xmonad 3 | Copyright (C) 2019 Markus Ongyerth 4 | 5 | This library is free software; you can redistribute it and/or 6 | modify it under the terms of the GNU Lesser General Public 7 | License as published by the Free Software Foundation; either 8 | version 2.1 of the License, or (at your option) any later version. 9 | 10 | This library is distributed in the hope that it will be useful, 11 | but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 13 | Lesser General Public License for more details. 14 | 15 | You should have received a copy of the GNU Lesser General Public 16 | License along with this library; if not, write to the Free Software 17 | Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA 18 | 19 | Reach us at https://github.com/ongy/waymonad 20 | -} 21 | module Waymonad.Protocols.DataControl 22 | where 23 | 24 | import Control.Monad.IO.Class (liftIO) 25 | 26 | import Graphics.Wayland.Server (DisplayServer(..)) 27 | import Graphics.Wayland.WlRoots.DataControl (dataControlManagerCreate) 28 | 29 | import Waymonad.Start (Bracketed (..)) 30 | 31 | getDataControlBracket :: Bracketed vs DisplayServer a 32 | getDataControlBracket = Bracketed (liftIO . dataControlManagerCreate) (const $ pure ()) 33 | 34 | -------------------------------------------------------------------------------- /src/Waymonad/Protocols/InputInhibit.hs-boot: -------------------------------------------------------------------------------- 1 | {- 2 | waymonad A wayland compositor in the spirit of xmonad 3 | Copyright (C) 2018 Markus Ongyerth 4 | 5 | This library is free software; you can redistribute it and/or 6 | modify it under the terms of the GNU Lesser General Public 7 | License as published by the Free Software Foundation; either 8 | version 2.1 of the License, or (at your option) any later version. 9 | 10 | This library is distributed in the hope that it will be useful, 11 | but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 13 | Lesser General Public License for more details. 14 | 15 | You should have received a copy of the GNU Lesser General Public 16 | License along with this library; if not, write to the Free Software 17 | Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA 18 | 19 | Reach us at https://github.com/ongy/waymonad 20 | -} 21 | module Waymonad.Protocols.InputInhibit 22 | where 23 | 24 | import Foreign.Ptr (Ptr) 25 | 26 | import Graphics.Wayland.Server (Client) 27 | import Graphics.Wayland.WlRoots.Surface (WlrSurface) 28 | 29 | import Waymonad.Types (Way) 30 | 31 | isInhibited :: Ptr WlrSurface -> Way vs ws Bool 32 | getInhibitingClient :: Way vs ws (Maybe Client) 33 | -------------------------------------------------------------------------------- /src/Waymonad/Protocols/LinuxDMABuf.hs: -------------------------------------------------------------------------------- 1 | {- 2 | waymonad A wayland compositor in the spirit of xmonad 3 | Copyright (C) 2018 Markus Ongyerth 4 | 5 | This library is free software; you can redistribute it and/or 6 | modify it under the terms of the GNU Lesser General Public 7 | License as published by the Free Software Foundation; either 8 | version 2.1 of the License, or (at your option) any later version. 9 | 10 | This library is distributed in the hope that it will be useful, 11 | but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 13 | Lesser General Public License for more details. 14 | 15 | You should have received a copy of the GNU Lesser General Public 16 | License along with this library; if not, write to the Free Software 17 | Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA 18 | 19 | Reach us at https://github.com/ongy/waymonad 20 | -} 21 | module Waymonad.Protocols.LinuxDMABuf 22 | where 23 | 24 | import Control.Monad.IO.Class (liftIO) 25 | import Foreign.Ptr (Ptr) 26 | 27 | import Graphics.Wayland.Server (DisplayServer(..)) 28 | import Graphics.Wayland.WlRoots.LinuxDMABuf (createDMABuf) 29 | import Graphics.Wayland.WlRoots.Backend (Backend) 30 | 31 | import Waymonad.Start (Bracketed (..)) 32 | 33 | getLinuxDMABufBracket :: Bracketed vs (DisplayServer, Ptr Backend) a 34 | getLinuxDMABufBracket = Bracketed (liftIO . uncurry createDMABuf) (const $ pure ()) 35 | -------------------------------------------------------------------------------- /src/Waymonad/Protocols/PrimarySelection.hs: -------------------------------------------------------------------------------- 1 | {- 2 | waymonad A wayland compositor in the spirit of xmonad 3 | Copyright (C) 2018 Markus Ongyerth 4 | 5 | This library is free software; you can redistribute it and/or 6 | modify it under the terms of the GNU Lesser General Public 7 | License as published by the Free Software Foundation; either 8 | version 2.1 of the License, or (at your option) any later version. 9 | 10 | This library is distributed in the hope that it will be useful, 11 | but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 13 | Lesser General Public License for more details. 14 | 15 | You should have received a copy of the GNU Lesser General Public 16 | License along with this library; if not, write to the Free Software 17 | Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA 18 | 19 | Reach us at https://github.com/ongy/waymonad 20 | -} 21 | {-# LANGUAGE OverloadedStrings #-} 22 | module Waymonad.Protocols.PrimarySelection 23 | ( getPrimarySelectionBracket 24 | ) 25 | where 26 | 27 | import Control.Monad.IO.Class (liftIO) 28 | 29 | import Graphics.Wayland.Server (DisplayServer) 30 | import Graphics.Wayland.WlRoots.PrimarySelection 31 | 32 | import Waymonad.GlobalFilter (registerGlobal) 33 | import Waymonad.Start (Bracketed (..)) 34 | import Waymonad.Types (Way) 35 | 36 | makeManager :: DisplayServer -> Way vs a PrimarySelectionManager 37 | makeManager dsp = do 38 | ptr <- liftIO $ createPrimaryDeviceManager dsp 39 | registerGlobal "PrimarySelection" =<< liftIO (getPrimaryGlobal ptr) 40 | pure ptr 41 | 42 | getPrimarySelectionBracket :: Bracketed vs DisplayServer a 43 | getPrimarySelectionBracket = Bracketed makeManager (liftIO . destroyPrimaryDeviceManager) 44 | -------------------------------------------------------------------------------- /src/Waymonad/Shells.hs: -------------------------------------------------------------------------------- 1 | {- 2 | waymonad A wayland compositor in the spirit of xmonad 3 | Copyright (C) 2018 Markus Ongyerth 4 | 5 | This library is free software; you can redistribute it and/or 6 | modify it under the terms of the GNU Lesser General Public 7 | License as published by the Free Software Foundation; either 8 | version 2.1 of the License, or (at your option) any later version. 9 | 10 | This library is distributed in the hope that it will be useful, 11 | but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 13 | Lesser General Public License for more details. 14 | 15 | You should have received a copy of the GNU Lesser General Public 16 | License along with this library; if not, write to the Free Software 17 | Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA 18 | 19 | Reach us at https://github.com/ongy/waymonad 20 | -} 21 | {-# LANGUAGE ExistentialQuantification #-} 22 | {-# LANGUAGE ScopedTypeVariables #-} 23 | module Waymonad.Shells 24 | where 25 | 26 | import Data.Set (Set) 27 | import Data.Text (Text) 28 | 29 | import Waymonad.View (View) 30 | import Waymonad.ViewSet (FocusCore, WSTag) 31 | import Waymonad.Types (Way, WayShell (..), ShellClass (..)) 32 | 33 | startShell :: (FocusCore vs ws, WSTag ws) => WayShell vs ws -> Way vs ws () 34 | startShell (WayShell shell) = activateShell shell 35 | 36 | stopShell :: (FocusCore vs ws, WSTag ws) => WayShell vs ws -> Way vs ws () 37 | stopShell (WayShell shell) = deactivateShell shell 38 | 39 | shellName :: WayShell vs ws -> Way vs ws Text 40 | shellName (WayShell shell) = getShellName shell 41 | 42 | shellActive :: WayShell vs ws -> Way vs ws Bool 43 | shellActive (WayShell shell) = isShellActive shell 44 | 45 | shellViews :: WayShell vs ws -> Way vs ws (Set View) 46 | shellViews (WayShell shell) = getShellViews shell 47 | -------------------------------------------------------------------------------- /src/Waymonad/Tabletv2.hs: -------------------------------------------------------------------------------- 1 | {- 2 | waymonad A wayland compositor in the spirit of xmonad 3 | Copyright (C) 2018 Markus Ongyerth 4 | 5 | This library is free software; you can redistribute it and/or 6 | modify it under the terms of the GNU Lesser General Public 7 | License as published by the Free Software Foundation; either 8 | version 2.1 of the License, or (at your option) any later version. 9 | 10 | This library is distributed in the hope that it will be useful, 11 | but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 13 | Lesser General Public License for more details. 14 | 15 | You should have received a copy of the GNU Lesser General Public 16 | License along with this library; if not, write to the Free Software 17 | Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA 18 | 19 | Reach us at https://github.com/ongy/waymonad 20 | -} 21 | {-# LANGUAGE OverloadedStrings #-} 22 | {-# LANGUAGE ScopedTypeVariables #-} 23 | {-# LANGUAGE LambdaCase #-} 24 | module Waymonad.Tabletv2 25 | ( getTabletv2Bracket 26 | , getManager 27 | ) 28 | where 29 | 30 | import Control.Monad.IO.Class (liftIO) 31 | 32 | import Graphics.Wayland.Server (DisplayServer) 33 | import Graphics.Wayland.WlRoots.Global 34 | 35 | import Waymonad.Utility.Extensible 36 | import Waymonad.Start (Bracketed (..)) 37 | import Waymonad.GlobalFilter 38 | import Waymonad.Types (Way) 39 | import Waymonad.GlobalFilter (registerGlobal) 40 | 41 | import qualified Graphics.Wayland.WlRoots.Tabletv2 as R 42 | 43 | makeManager :: DisplayServer -> Way vs a R.TabletManagerv2 44 | makeManager dsp = do 45 | ret <- liftIO $ R.createTabletManagerv2 dsp 46 | registerGlobal "Tabletv2" =<< (liftIO $ getGlobal ret) 47 | setEState $ Just ret 48 | pure ret 49 | 50 | getTabletv2Bracket :: Bracketed vs DisplayServer a 51 | getTabletv2Bracket = Bracketed makeManager (liftIO . removeGlobal) 52 | 53 | getManager :: Way vs ws (Maybe R.TabletManagerv2) 54 | getManager = getEState 55 | -------------------------------------------------------------------------------- /src/Waymonad/Types/Logger.hs: -------------------------------------------------------------------------------- 1 | {- 2 | waymonad A wayland compositor in the spirit of xmonad 3 | Copyright (C) 2017 Markus Ongyerth 4 | 5 | This library is free software; you can redistribute it and/or 6 | modify it under the terms of the GNU Lesser General Public 7 | License as published by the Free Software Foundation; either 8 | version 2.1 of the License, or (at your option) any later version. 9 | 10 | This library is distributed in the hope that it will be useful, 11 | but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 13 | Lesser General Public License for more details. 14 | 15 | You should have received a copy of the GNU Lesser General Public 16 | License along with this library; if not, write to the Free Software 17 | Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA 18 | 19 | Reach us at https://github.com/ongy/waymonad 20 | -} 21 | module Waymonad.Types.Logger 22 | where 23 | 24 | import Data.Text (Text) 25 | 26 | data LogPriority 27 | = Error 28 | | Warn 29 | | Info 30 | | Debug 31 | | Trace 32 | deriving (Eq, Show, Ord) 33 | 34 | data Logger = Logger 35 | { loggerLevel :: LogPriority 36 | , loggerName :: Text 37 | } deriving (Eq, Show) 38 | 39 | data WayLoggers = WayLoggers 40 | { loggerOutput :: Logger 41 | , loggerWS :: Logger 42 | , loggerFocus :: Logger 43 | , loggerXdg :: Logger 44 | , loggerX11 :: Logger 45 | , loggerKeybinds :: Logger 46 | , loggerSpawner :: Logger 47 | , loggerLayout :: Logger 48 | , loggerRender :: Logger 49 | } deriving (Eq, Show) 50 | -------------------------------------------------------------------------------- /src/Waymonad/Utility/Base.hs: -------------------------------------------------------------------------------- 1 | {- 2 | waymonad A wayland compositor in the spirit of xmonad 3 | Copyright (C) 2017 Markus Ongyerth 4 | 5 | This library is free software; you can redistribute it and/or 6 | modify it under the terms of the GNU Lesser General Public 7 | License as published by the Free Software Foundation; either 8 | version 2.1 of the License, or (at your option) any later version. 9 | 10 | This library is distributed in the hope that it will be useful, 11 | but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 13 | Lesser General Public License for more details. 14 | 15 | You should have received a copy of the GNU Lesser General Public 16 | License along with this library; if not, write to the Free Software 17 | Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA 18 | 19 | Reach us at https://github.com/ongy/waymonad 20 | -} 21 | module Waymonad.Utility.Base 22 | ( intToPtr 23 | , ptrToInt 24 | , whenJust 25 | , doJust 26 | 27 | , These (..) 28 | , getThis 29 | , getThat 30 | 31 | , firstDir 32 | 33 | , showT 34 | , readT 35 | ) 36 | where 37 | 38 | import Data.Default (Default (..)) 39 | import Data.Text (Text) 40 | import Foreign.Ptr (Ptr, ptrToIntPtr, intPtrToPtr) 41 | import Safe (readMay) 42 | 43 | import qualified Data.Text as T 44 | 45 | intToPtr :: Integral a => a -> Ptr b 46 | intToPtr = intPtrToPtr . fromIntegral 47 | 48 | ptrToInt :: Num b => Ptr a -> b 49 | ptrToInt = fromIntegral . ptrToIntPtr 50 | 51 | whenJust :: (Applicative m, Default r) => Maybe a -> (a -> m r) -> m r 52 | whenJust Nothing _ = pure def 53 | whenJust (Just x) f = f x 54 | 55 | doJust :: (Monad m, Default r) => m (Maybe a) -> (a -> m r) -> m r 56 | doJust val act = flip whenJust act =<< val 57 | 58 | data These a = This a | That a | These a a 59 | deriving (Eq, Show, Read) 60 | 61 | instance Functor These where 62 | fmap f (This a) = This $ f a 63 | fmap f (That a) = That $ f a 64 | fmap f (These a b) = These (f a) (f b) 65 | 66 | getThis :: These a -> Maybe a 67 | getThis (This x) = Just x 68 | getThis (These x _) = Just x 69 | getThis _ = Nothing 70 | 71 | getThat :: These a -> Maybe a 72 | getThat (That x) = Just x 73 | getThat (These _ x) = Just x 74 | getThat _ = Nothing 75 | 76 | firstDir :: String -> (String, String) 77 | firstDir [] = ([], []) 78 | firstDir path = span (/= '/') path 79 | 80 | showT :: Show a => a -> Text 81 | showT = T.pack . show 82 | 83 | readT :: Read a => Text -> Maybe a 84 | readT = readMay . T.unpack 85 | -------------------------------------------------------------------------------- /src/Waymonad/Utility/Extensible.hs: -------------------------------------------------------------------------------- 1 | {- 2 | waymonad A wayland compositor in the spirit of xmonad 3 | Copyright (C) 2018 Markus Ongyerth 4 | 5 | This library is free software; you can redistribute it and/or 6 | modify it under the terms of the GNU Lesser General Public 7 | License as published by the Free Software Foundation; either 8 | version 2.1 of the License, or (at your option) any later version. 9 | 10 | This library is distributed in the hope that it will be useful, 11 | but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 13 | Lesser General Public License for more details. 14 | 15 | You should have received a copy of the GNU Lesser General Public 16 | License along with this library; if not, write to the Free Software 17 | Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA 18 | 19 | Reach us at https://github.com/ongy/waymonad 20 | -} 21 | module Waymonad.Utility.Extensible 22 | where 23 | 24 | import Control.Monad.IO.Class 25 | import Data.IORef (modifyIORef, readIORef) 26 | 27 | import Waymonad (getState) 28 | import Waymonad.Types 29 | import Waymonad.Extensible 30 | 31 | 32 | modifyStateRef :: (StateMap -> StateMap) -> Way vs a () 33 | modifyStateRef fun = do 34 | ref <- wayExtensibleState <$> getState 35 | liftIO $ modifyIORef ref fun 36 | 37 | modifyEState :: ExtensionClass a => (a -> a) -> Way vs b () 38 | modifyEState = modifyStateRef . modifyValue 39 | 40 | setEState :: ExtensionClass a => a -> Way vs b () 41 | setEState = modifyStateRef . setValue 42 | 43 | getEState :: ExtensionClass a => Way vs b a 44 | getEState = do 45 | state <- liftIO . readIORef . wayExtensibleState =<< getState 46 | pure $ getValue state 47 | 48 | -------------------------------------------------------------------------------- /src/Waymonad/Utility/HaskellSignal.hs: -------------------------------------------------------------------------------- 1 | {- 2 | waymonad A wayland compositor in the spirit of xmonad 3 | Copyright (C) 2018 Markus Ongyerth 4 | 5 | This library is free software; you can redistribute it and/or 6 | modify it under the terms of the GNU Lesser General Public 7 | License as published by the Free Software Foundation; either 8 | version 2.1 of the License, or (at your option) any later version. 9 | 10 | This library is distributed in the hope that it will be useful, 11 | but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 13 | Lesser General Public License for more details. 14 | 15 | You should have received a copy of the GNU Lesser General Public 16 | License along with this library; if not, write to the Free Software 17 | Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA 18 | 19 | Reach us at https://github.com/ongy/waymonad 20 | -} 21 | module Waymonad.Utility.HaskellSignal 22 | ( HaskellSignalToken 23 | , HaskellSignal 24 | , addHaskellListener 25 | , makeHaskellSignal 26 | , removeHaskellListener 27 | , emitHaskellSignal 28 | ) 29 | where 30 | 31 | import Control.Monad.IO.Class (liftIO, MonadIO) 32 | import Data.IntMap (IntMap) 33 | import Data.IORef (IORef, newIORef, readIORef, writeIORef, modifyIORef) 34 | 35 | import qualified Data.IntMap as IM 36 | 37 | data HaskellSignalToken v m = HaskellSignalToken Int (HaskellSignal v m) 38 | data HaskellSignal v m = HaskellSignal { _hsSignalMap :: IORef (IntMap (v -> m ())), _hsSignalCounter :: IORef Int } 39 | 40 | makeHaskellSignal :: MonadIO m => m (HaskellSignal v n) 41 | makeHaskellSignal = liftIO (HaskellSignal <$> newIORef mempty <*> newIORef 0) 42 | 43 | addHaskellListener :: MonadIO m => HaskellSignal v n -> (v -> n ()) -> m (HaskellSignalToken v n) 44 | addHaskellListener s@(HaskellSignal mapRef counter) act = liftIO $ do 45 | value <- readIORef counter 46 | writeIORef counter (value + 1) 47 | 48 | modifyIORef mapRef (IM.insert value act) 49 | pure $ HaskellSignalToken value s 50 | 51 | removeHaskellListener :: MonadIO m => HaskellSignalToken v n -> m () 52 | removeHaskellListener (HaskellSignalToken v (HaskellSignal refMap _)) = liftIO $ 53 | modifyIORef refMap (IM.delete v) 54 | 55 | emitHaskellSignal :: MonadIO m => v -> HaskellSignal v m -> m () 56 | emitHaskellSignal v (HaskellSignal mapRef _) = do 57 | lMap <- liftIO $ readIORef mapRef 58 | mapM_ ($ v) $ IM.elems lMap 59 | -------------------------------------------------------------------------------- /src/Waymonad/Utility/LayerCache.hs: -------------------------------------------------------------------------------- 1 | {- 2 | waymonad A wayland compositor in the spirit of xmonad 3 | Copyright (C) 2018 Markus Ongyerth 4 | 5 | This library is free software; you can redistribute it and/or 6 | modify it under the terms of the GNU Lesser General Public 7 | License as published by the Free Software Foundation; either 8 | version 2.1 of the License, or (at your option) any later version. 9 | 10 | This library is distributed in the hope that it will be useful, 11 | but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 13 | Lesser General Public License for more details. 14 | 15 | You should have received a copy of the GNU Lesser General Public 16 | License along with this library; if not, write to the Free Software 17 | Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA 18 | 19 | Reach us at https://github.com/ongy/waymonad 20 | -} 21 | module Waymonad.Utility.LayerCache 22 | where 23 | 24 | import Control.Monad (forM_, forM) 25 | import Control.Monad.IO.Class (liftIO, MonadIO) 26 | import Data.IORef (readIORef, writeIORef) 27 | import Data.Text (Text) 28 | import Foreign.Ptr (Ptr) 29 | 30 | import Graphics.Pixman 31 | import Graphics.Wayland.WlRoots.Box (WlrBox (..), Point (..)) 32 | import Graphics.Wayland.WlRoots.Output (WlrOutput) 33 | 34 | import Waymonad.Output (outApplyDamage) 35 | import Waymonad.View (viewHasCSD) 36 | import Waymonad.Types (SSDPrio, Output (..), Way) 37 | import Waymonad.Types.Core (View) 38 | import Waymonad.Utility.Mapping (getOutputs) 39 | import Waymonad.Utility.SSD 40 | 41 | import qualified Data.Map as M 42 | 43 | getViewPosition :: MonadIO m => View -> [(View, SSDPrio, WlrBox)] -> m [WlrBox] 44 | getViewPosition view xs = do 45 | let ret = filter (\(v, _, _) -> view == v) xs 46 | mapM (\(v, p, b) -> do 47 | hasCSD <- liftIO $ viewHasCSD v 48 | pure $ getDecoBox hasCSD p b 49 | ) ret 50 | 51 | getViewBoxInLayer :: MonadIO m 52 | => Output -> View -> Text -> m ([WlrBox]) 53 | getViewBoxInLayer Output {outputLayers = layers} view layer = liftIO $ do 54 | case M.lookup layer layers of 55 | Nothing -> pure [] 56 | Just ref -> getViewPosition view =<< readIORef ref 57 | 58 | setLayerContent :: MonadIO m => Text -> Output -> [(View, SSDPrio, WlrBox)] -> m () 59 | setLayerContent layer Output {outputLayers = layers} content = liftIO $ do 60 | case M.lookup layer layers of 61 | Nothing -> pure () 62 | Just ref -> writeIORef ref content 63 | 64 | getLayerContent :: MonadIO m => Text -> Output -> m [(View, SSDPrio, WlrBox)] 65 | getLayerContent layer Output {outputLayers = layers} = liftIO $ do 66 | case M.lookup layer layers of 67 | Nothing -> pure [] 68 | Just ref -> readIORef ref 69 | 70 | 71 | getLayerPosition :: Text -> View -> Way vs ws [(Output, Point)] 72 | getLayerPosition layer view = do 73 | outs <- getOutputs 74 | ret <- liftIO $ forM outs $ \out -> do 75 | boxes <- getViewBoxInLayer out view layer 76 | pure $ fmap (\(WlrBox x y _ _) -> (out, Point x y)) boxes 77 | 78 | pure . concat $ ret 79 | 80 | getLayerPosition' :: Text -> View -> Way vs ws [(Ptr WlrOutput, Point)] 81 | getLayerPosition' layer view = do 82 | ret <- getLayerPosition layer view 83 | pure $ fmap (\(o, p) -> (outputRoots o, p)) ret 84 | 85 | applyLayerDamage :: Text -> View -> PixmanRegion32-> Way vs ws () 86 | applyLayerDamage layer view orig = do 87 | outs <- getOutputs 88 | liftIO $ forM_ outs $ \out -> do 89 | boxes <- getViewBoxInLayer out view layer 90 | forM_ boxes $ \(WlrBox x y _ _) -> withRegionCopy orig $ \region -> do 91 | pixmanRegionTranslate region x y 92 | outApplyDamage out (Just region) 93 | -------------------------------------------------------------------------------- /src/Waymonad/Utility/Log.hs: -------------------------------------------------------------------------------- 1 | {- 2 | waymonad A wayland compositor in the spirit of xmonad 3 | Copyright (C) 2017 Markus Ongyerth 4 | 5 | This library is free software; you can redistribute it and/or 6 | modify it under the terms of the GNU Lesser General Public 7 | License as published by the Free Software Foundation; either 8 | version 2.1 of the License, or (at your option) any later version. 9 | 10 | This library is distributed in the hope that it will be useful, 11 | but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 13 | Lesser General Public License for more details. 14 | 15 | You should have received a copy of the GNU Lesser General Public 16 | License along with this library; if not, write to the Free Software 17 | Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA 18 | 19 | Reach us at https://github.com/ongy/waymonad 20 | -} 21 | {-# LANGUAGE OverloadedStrings #-} 22 | module Waymonad.Utility.Log 23 | ( logPutText 24 | , logPutStr 25 | , logPrint 26 | , LogPriority (..) 27 | , Logger (..) 28 | 29 | , logPutText' 30 | ) 31 | where 32 | 33 | import Control.Monad (when) 34 | import Control.Monad.IO.Class (liftIO) 35 | import Data.Text (Text) 36 | import Data.Time.Clock (getCurrentTime) 37 | import Data.Time.Format (formatTime, defaultTimeLocale) 38 | import System.IO (hPutStr, stderr) 39 | 40 | import qualified Data.Text as T 41 | import qualified Data.Text.IO as T 42 | 43 | import Waymonad 44 | ( Way 45 | , getLoggers 46 | , WayLoggers (..) 47 | , Logger (..) 48 | ) 49 | import Waymonad.Types ( 50 | LogPriority (..) 51 | ) 52 | 53 | logPutTime :: IO () 54 | logPutTime = do 55 | time <- getCurrentTime 56 | let formatted = formatTime defaultTimeLocale "%0Y-%m-%d %H:%M:%S - " time 57 | 58 | hPutStr stderr formatted 59 | 60 | logPutText' :: Text -> Text -> Way vs a () 61 | logPutText' name arg = liftIO $ do 62 | logPutTime 63 | T.hPutStr stderr name 64 | T.hPutStr stderr ": " 65 | T.hPutStrLn stderr arg 66 | 67 | logPutText :: (WayLoggers -> Logger) -> LogPriority -> Text -> Way vs a () 68 | logPutText fun prio arg = do 69 | (Logger lvl name) <- fun <$> getLoggers 70 | when (prio <= lvl) $ logPutText' name arg 71 | 72 | logPutStr :: (WayLoggers -> Logger) -> LogPriority -> String -> Way vs a () 73 | logPutStr select prio arg = logPutText select prio (T.pack arg) 74 | 75 | logPrint :: (Show a) => (WayLoggers -> Logger) -> LogPriority -> a -> Way vs b () 76 | logPrint fun prio = logPutStr fun prio . show 77 | 78 | -------------------------------------------------------------------------------- /src/Waymonad/Utility/Pointer.hs: -------------------------------------------------------------------------------- 1 | {- 2 | waymonad A wayland compositor in the spirit of xmonad 3 | Copyright (C) 2018 Markus Ongyerth 4 | 5 | This library is free software; you can redistribute it and/or 6 | modify it under the terms of the GNU Lesser General Public 7 | License as published by the Free Software Foundation; either 8 | version 2.1 of the License, or (at your option) any later version. 9 | 10 | This library is distributed in the hope that it will be useful, 11 | but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 13 | Lesser General Public License for more details. 14 | 15 | You should have received a copy of the GNU Lesser General Public 16 | License along with this library; if not, write to the Free Software 17 | Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA 18 | 19 | Reach us at https://github.com/ongy/waymonad 20 | -} 21 | module Waymonad.Utility.Pointer 22 | where 23 | 24 | import Control.Monad.IO.Class (liftIO) 25 | 26 | import Graphics.Wayland.WlRoots.Box (Point (..), WlrBox (..)) 27 | import Graphics.Wayland.WlRoots.OutputLayout (getOutputLayoutExtends) 28 | 29 | import Waymonad.Utility.Base (doJust) 30 | import Waymonad.ViewSet 31 | import Waymonad (getSeat, getState) 32 | import Waymonad.Input.Seat (setPointerPosition, Seat) 33 | import Waymonad.Types 34 | 35 | 36 | sendPointerTo :: (FocusCore vs ws, WSTag ws) => Point -> Way vs ws () 37 | sendPointerTo p = doJust getSeat $ sendSeatTo p 38 | 39 | sendSeatTo :: (FocusCore vs ws, WSTag ws) => Point -> Seat -> Way vs ws () 40 | sendSeatTo (Point dx dy) seat = do 41 | Compositor {compLayout = layout} <- wayCompositor <$> getState 42 | WlrBox _ _ lw lh <- liftIO $ getOutputLayoutExtends layout 43 | let pos = (fromIntegral dx / fromIntegral lw, fromIntegral dy / fromIntegral lh) 44 | setPointerPosition seat pos 45 | -------------------------------------------------------------------------------- /src/Waymonad/Utility/Signal.hs: -------------------------------------------------------------------------------- 1 | {- 2 | waymonad A wayland compositor in the spirit of xmonad 3 | Copyright (C) 2018 Markus Ongyerth 4 | 5 | This library is free software; you can redistribute it and/or 6 | modify it under the terms of the GNU Lesser General Public 7 | License as published by the Free Software Foundation; either 8 | version 2.1 of the License, or (at your option) any later version. 9 | 10 | This library is distributed in the hope that it will be useful, 11 | but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 13 | Lesser General Public License for more details. 14 | 15 | You should have received a copy of the GNU Lesser General Public 16 | License along with this library; if not, write to the Free Software 17 | Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA 18 | 19 | Reach us at https://github.com/ongy/waymonad 20 | -} 21 | {-| 22 | Module : Waymonad.Utility.Signal 23 | Description : Utility functions to attach to wayland signals. Probably useless for endusers 24 | Maintainer : ongy 25 | Stability : testing 26 | Portability : Linux 27 | -} 28 | module Waymonad.Utility.Signal 29 | ( setSignalHandler 30 | , setSignalHandlerIO 31 | , setDestroyHandler 32 | ) 33 | where 34 | 35 | import Control.Concurrent.MVar (newEmptyMVar, takeMVar, putMVar) 36 | import Control.Monad.IO.Class (liftIO) 37 | import Foreign.Ptr (Ptr) 38 | 39 | import Graphics.Wayland.Signal 40 | ( addListener 41 | , WlListener (..) 42 | , ListenerToken 43 | , WlSignal 44 | , destroyListener 45 | ) 46 | 47 | import Waymonad (setCallback) 48 | import Waymonad.Types (Way) 49 | 50 | 51 | -- | Set a 'Way' action as signal handler. 52 | setSignalHandler :: Ptr (WlSignal a) 53 | -> (Ptr a -> Way vs b ()) 54 | -> Way vs b ListenerToken 55 | setSignalHandler signal act = 56 | setCallback act (\fun -> addListener (WlListener fun) signal) 57 | 58 | -- | Set a 'Way' action as signal handler. 59 | setSignalHandlerIO :: Ptr (WlSignal a) 60 | -> (Ptr a -> IO ()) 61 | -> IO ListenerToken 62 | setSignalHandlerIO signal act = addListener (WlListener act) signal 63 | 64 | -- | Set a signal handler that will remove itself after it's fired once. This 65 | -- can be used for destroy handlers that don't have to be stored anywhere. 66 | setDestroyHandler :: Ptr (WlSignal a) 67 | -> (Ptr a -> Way vs b ()) 68 | -> Way vs b () 69 | setDestroyHandler signal handler = do 70 | var <- liftIO newEmptyMVar 71 | listener <- setSignalHandler signal $ \ptr -> do 72 | handler ptr 73 | liftIO $ (destroyListener =<< takeMVar var) 74 | liftIO $ putMVar var listener 75 | -------------------------------------------------------------------------------- /waymonad-scanner/.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | dist-newstyle 3 | .ghc.environment* 4 | -------------------------------------------------------------------------------- /waymonad-scanner/ChangeLog.md: -------------------------------------------------------------------------------- 1 | # Revision history for hayland-scanner 2 | 3 | ## 0.1.0.0 -- YYYY-mm-dd 4 | 5 | * First version. Released on an unsuspecting world. 6 | -------------------------------------------------------------------------------- /waymonad-scanner/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /waymonad-scanner/src/Graphics/Wayland/Scanner.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | module Graphics.Wayland.Scanner 5 | where 6 | 7 | import Foreign.Ptr (Ptr) 8 | import Control.Monad.Fail (MonadFail) 9 | import Control.Monad.Trans (MonadTrans(lift)) 10 | 11 | import Graphics.Wayland.Scanner.Dispatcher 12 | import Graphics.Wayland.Scanner.Marshal 13 | import Graphics.Wayland.Scanner.Types 14 | import Graphics.Wayland.Scanner.WLS 15 | import Graphics.Wayland.Scanner.XML 16 | 17 | import Utility 18 | 19 | import qualified Language.Haskell.TH as TH 20 | 21 | #if MIN_VERSION_template_haskell(2, 12, 0) 22 | import System.Process (readProcess) 23 | import qualified Language.Haskell.TH.Syntax as THS 24 | #endif 25 | 26 | makeInterfaceGetter :: String -> TH.Dec 27 | makeInterfaceGetter iface = 28 | let ifaceName = iface ++ "_interface" 29 | funName = TH.mkName $ replaceUnder iface ++ "Interface" 30 | importType = TH.AppT (TH.ConT ''Ptr) (TH.ConT ''WlInterface) 31 | in TH.ForeignD $ TH.ImportF TH.CCall TH.Safe ('&':ifaceName) funName importType 32 | 33 | makeInterfaceDecls :: (Monad m, MonadFail m) => (String, Interface, Int) -> Scanner m [TH.Dec] 34 | makeInterfaceDecls (name, (Interface _ reqs evts), _) = do 35 | reqD <- if null reqs 36 | then pure [] 37 | else makeDispatcher name $ map (\(n, WlRequest x) -> (n, map snd x)) reqs 38 | evtD <- mapM (\((n, WlEvent x), i) -> makePostFun (TH.mkName $ replaceUnder name ++ "Post" ++ cleanName n) (map snd x) i) $ zip evts [0 ..] 39 | pure $ makeInterfaceGetter name : reqD ++ concat evtD 40 | 41 | protocolFromFile :: String -> Scanner TH.Q [TH.Dec] 42 | protocolFromFile file = do 43 | WlProtocol _ ifaces <- scannerIO $ protFromFile file 44 | ret <- mapM makeInterfaceDecls ifaces 45 | Scanner . lift $ generateInterface file 46 | pure $ concat ret 47 | 48 | generateInterface :: String -> TH.Q () 49 | #if MIN_VERSION_template_haskell(2, 12, 0) 50 | generateInterface file = do 51 | content <- TH.runIO $ readProcess "wayland-scanner" ["code", file, "/dev/stdout"] "" 52 | THS.addForeignSource THS.LangC content 53 | #else 54 | generateInterface _ = pure () 55 | #endif 56 | -------------------------------------------------------------------------------- /waymonad-scanner/src/Graphics/Wayland/Scanner/Types.hs: -------------------------------------------------------------------------------- 1 | module Graphics.Wayland.Scanner.Types 2 | where 3 | 4 | data ArgumentType 5 | = IntArg 6 | | UIntArg 7 | | FixedArg 8 | | StringArg 9 | | NullableStringArg 10 | | ObjectArg String 11 | | NullableObjectArg String 12 | | NewIdArg String 13 | | NullableNewIdArg String 14 | | ArrayArg 15 | | NullableArrayArg 16 | | FdArg 17 | deriving (Show) 18 | 19 | argTypeFromData :: String -> Bool -> Maybe String -> ArgumentType 20 | argTypeFromData "int" _ _ = IntArg 21 | argTypeFromData "uint" _ _ = UIntArg 22 | argTypeFromData "fixed" _ _ = FixedArg 23 | argTypeFromData "string" False _ = StringArg 24 | argTypeFromData "string" True _ = NullableStringArg 25 | argTypeFromData "object" False (Just s) = ObjectArg s 26 | argTypeFromData "object" True (Just s) = NullableObjectArg s 27 | argTypeFromData "new_id" False (Just s) = NewIdArg s 28 | argTypeFromData "new_id" True (Just s) = NullableNewIdArg s 29 | argTypeFromData "array" False _ = ArrayArg 30 | argTypeFromData "array" True _ = NullableArrayArg 31 | argTypeFromData "fd" _ _ = FdArg 32 | argTypeFromData x _ _ = error $ "Can't decode " ++ x ++ " as argument type" 33 | 34 | newtype WlEnum = WlEnum [(String, Int)] 35 | newtype WlRequest = WlRequest [(String, ArgumentType)] 36 | newtype WlEvent = WlEvent [(String, ArgumentType)] 37 | 38 | data Interface = Interface [(String, WlEnum)] [(String, WlRequest)] [(String, WlEvent)] 39 | 40 | data WlProtocol = WlProtocol String [(String, Interface, Int)] 41 | -------------------------------------------------------------------------------- /waymonad-scanner/src/Graphics/Wayland/Scanner/WLS.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 4 | module Graphics.Wayland.Scanner.WLS 5 | ( Scanner (..) 6 | , ScannerEnv (..) 7 | , getObjectConvert 8 | , scannerIO 9 | , runScanner 10 | ) 11 | where 12 | 13 | import Control.Monad.Fail (MonadFail) 14 | import Control.Monad.Trans (MonadTrans(lift)) 15 | import Control.Monad.Reader (MonadReader, ReaderT, ask, runReaderT) 16 | import Data.Map (Map) 17 | import Data.Maybe (fromMaybe) 18 | import Foreign.Ptr (Ptr) 19 | 20 | import Graphics.Wayland.Resource (WlResource) 21 | 22 | import qualified Data.Map as M 23 | import qualified Language.Haskell.TH as TH 24 | 25 | type ObjectMap = Map String (TH.Type, TH.Exp, TH.Exp) 26 | 27 | data ScannerEnv = ScannerEnv 28 | { scannerObjectMap :: ObjectMap 29 | } 30 | 31 | newtype Scanner m a = Scanner (ReaderT ScannerEnv m a) 32 | deriving (Functor, Applicative, Monad, MonadReader ScannerEnv, MonadFail) 33 | 34 | getObjectMap :: Monad m => Scanner m ObjectMap 35 | getObjectMap = scannerObjectMap <$> ask 36 | 37 | getObjectConvert :: Monad m => String -> Scanner m (TH.Type, TH.Exp, TH.Exp) 38 | getObjectConvert name = do 39 | oMap <- getObjectMap 40 | pure $ fromMaybe (TH.AppT (TH.ConT ''Ptr) (TH.ConT ''WlResource), TH.VarE 'pure, TH.LamE [TH.WildP] (TH.VarE 'pure)) $ M.lookup name oMap 41 | 42 | scannerIO :: IO a -> Scanner TH.Q a 43 | scannerIO = Scanner . lift . TH.runIO 44 | 45 | runScanner :: Scanner m a -> ScannerEnv -> m a 46 | runScanner (Scanner act) env = runReaderT act env 47 | -------------------------------------------------------------------------------- /waymonad-scanner/src/Graphics/Wayland/Scanner/XML.hs: -------------------------------------------------------------------------------- 1 | module Graphics.Wayland.Scanner.XML 2 | ( parseProtocol 3 | , protFromFile 4 | ) 5 | where 6 | 7 | import Data.Maybe (fromMaybe, mapMaybe) 8 | import Text.XML.Light.Input (parseXMLDoc) 9 | import Text.XML.Light.Lexer (XmlSource) 10 | import Text.XML.Light.Types 11 | import Text.XML.Light.Proc 12 | 13 | import Graphics.Wayland.Scanner.Types 14 | 15 | --data Interface = Interface [(String, WlEnum)] [(String, WlRequest)] [(String, WlEvent)] 16 | 17 | argTypeFromXml :: Element -> ArgumentType 18 | argTypeFromXml e = 19 | let tStr = findAttr (QName "type" Nothing Nothing) e 20 | nullAttr = findAttr (QName "allow-null" Nothing Nothing) e 21 | nullable = maybe False ("true" ==) nullAttr 22 | tName = fromMaybe (error "Couldn't find type attribute") tStr 23 | iface = findAttr (QName "interface" Nothing Nothing) e 24 | in argTypeFromData tName nullable iface 25 | 26 | 27 | argFromElem :: Element -> Maybe (String, ArgumentType) 28 | argFromElem el = case elName el == QName "arg" Nothing Nothing of 29 | False -> Nothing 30 | True -> 31 | let name = fromMaybe (error "Can't find argument name") $ findAttr (QName "name" Nothing Nothing) el 32 | aType = argTypeFromXml el 33 | in Just (name, aType) 34 | 35 | eventsFromElem :: Element -> [(String, WlEvent)] 36 | eventsFromElem el = 37 | let getReq el' = case elName el' == QName "event" Nothing Nothing of 38 | False -> Nothing 39 | True -> 40 | let name = fromMaybe (error "Can't find request name") $ findAttr (QName "name" Nothing Nothing) el' 41 | args = mapMaybe argFromElem $ elChildren el' 42 | in Just (name, WlEvent args) 43 | in mapMaybe getReq $ elChildren el 44 | 45 | requestsFromElem :: Element -> [(String, WlRequest)] 46 | requestsFromElem el = 47 | let getReq el' = case elName el' == QName "request" Nothing Nothing of 48 | False -> Nothing 49 | True -> 50 | let name = fromMaybe (error "Can't find request name") $ findAttr (QName "name" Nothing Nothing) el' 51 | args = mapMaybe argFromElem $ elChildren el' 52 | in Just (name, WlRequest args) 53 | in mapMaybe getReq $ elChildren el 54 | 55 | interfaceFromElem :: Element -> Maybe (String, Interface, Int) 56 | interfaceFromElem el = case elName el == QName "interface" Nothing Nothing of 57 | False -> Nothing 58 | True -> 59 | let name = fromMaybe (error "Can't find interface name") $ findAttr (QName "name" Nothing Nothing) el 60 | version = fromMaybe (error "Can't find interface version") $ findAttr (QName "version" Nothing Nothing) el 61 | in Just (name, Interface [] (requestsFromElem el) (eventsFromElem el), read version) 62 | 63 | protFromElem :: Element -> WlProtocol 64 | protFromElem el = 65 | let name = fromMaybe (error "Can't find protocol name") $ findAttr (QName "name" Nothing Nothing) el 66 | elems = mapMaybe interfaceFromElem $ elChildren el 67 | in WlProtocol name elems 68 | 69 | parseProtocol :: XmlSource s => s -> WlProtocol 70 | parseProtocol src = protFromElem $ 71 | fromMaybe (error "Failed to parse XML document") $ parseXMLDoc src 72 | 73 | protFromFile :: String -> IO WlProtocol 74 | protFromFile file = do 75 | content <- readFile file 76 | pure $ parseProtocol content 77 | -------------------------------------------------------------------------------- /waymonad-scanner/src/Utility.hs: -------------------------------------------------------------------------------- 1 | module Utility 2 | where 3 | 4 | import Data.Char (toUpper) 5 | 6 | capitalizeFirst :: String -> String 7 | capitalizeFirst [] = [] 8 | capitalizeFirst (c:str) = toUpper c : str 9 | 10 | replaceUnder :: String -> String 11 | replaceUnder [] = [] 12 | replaceUnder "_" = [] 13 | replaceUnder ('_':c:xs) = toUpper c : replaceUnder xs 14 | replaceUnder (x:xs) = x : replaceUnder xs 15 | 16 | cleanName :: String -> String 17 | cleanName = capitalizeFirst . replaceUnder 18 | -------------------------------------------------------------------------------- /waymonad-scanner/waymonad-scanner.cabal: -------------------------------------------------------------------------------- 1 | -- Initial waymonad-scanner.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: waymonad-scanner 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: 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: System 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.Wayland.Scanner 52 | exposed-modules: Graphics.Wayland.Scanner.Dispatcher 53 | exposed-modules: Graphics.Wayland.Scanner.Marshal 54 | exposed-modules: Graphics.Wayland.Scanner.Types 55 | exposed-modules: Graphics.Wayland.Scanner.WLS 56 | exposed-modules: Graphics.Wayland.Scanner.XML 57 | 58 | -- Modules included in this library but not exported. 59 | other-modules: Utility 60 | 61 | -- LANGUAGE extensions used by modules in this package. 62 | -- other-extensions: 63 | 64 | -- Other library packages from which modules are imported. 65 | build-depends: base >=4.8 && <5, mtl, containers 66 | build-depends: cereal, text, bytestring, process 67 | build-depends: template-haskell 68 | build-depends: hayland, xml >= 1.3 && < 1.4, hsroots 69 | 70 | -- Directories containing source files. 71 | hs-source-dirs: src 72 | 73 | -- Base language which the package is written in. 74 | default-language: Haskell2010 75 | ghc-options: -Wall 76 | PkgConfig-Depends: wayland-server 77 | -------------------------------------------------------------------------------- /waymonad-scanner/waymonad-scanner.nix: -------------------------------------------------------------------------------- 1 | { mkDerivation, base, bytestring, cereal, containers, hayland 2 | , hsroots, lib, mtl, process, template-haskell, text, wayland, xml 3 | }: 4 | mkDerivation { 5 | pname = "waymonad-scanner"; 6 | version = "0.1.0.0"; 7 | src = ./.; 8 | libraryHaskellDepends = [ 9 | base bytestring cereal containers hayland hsroots mtl process 10 | template-haskell text xml 11 | ]; 12 | libraryPkgconfigDepends = [ wayland ]; 13 | license = lib.licenses.lgpl21Only; 14 | } 15 | -------------------------------------------------------------------------------- /waymonad.nix: -------------------------------------------------------------------------------- 1 | { mkDerivation, base, bytestring, clock, composition, config-schema 2 | , config-value, containers, data-default, deepseq, directory 3 | , formatting, ghc-prim, hayland, HFuse, hsroots, lib, hslibinput 4 | , mtl, network, process, safe, semigroupoids, stm 5 | , template-haskell, text, time, transformers, unix, unliftio 6 | , unliftio-core, waymonad-scanner, xdg-basedir, xkbcommon 7 | }: 8 | mkDerivation { 9 | pname = "waymonad"; 10 | version = "0.0.1.0"; 11 | src = ./.; 12 | isLibrary = true; 13 | isExecutable = true; 14 | libraryHaskellDepends = [ 15 | base bytestring clock composition config-schema config-value 16 | containers data-default deepseq directory formatting ghc-prim 17 | hayland HFuse hsroots hslibinput mtl network process safe 18 | semigroupoids stm template-haskell text time transformers unix 19 | unliftio unliftio-core waymonad-scanner xdg-basedir xkbcommon 20 | ]; 21 | executableHaskellDepends = [ 22 | base containers hayland hsroots hslibinput text xkbcommon 23 | ]; 24 | homepage = "https://github.com/ongy/waymonad"; 25 | description = "Wayland compositor build on the ideas of Xmonad"; 26 | license = lib.licenses.lgpl21Only; 27 | } 28 | --------------------------------------------------------------------------------