├── .dir-locals.el ├── .github └── ISSUE_TEMPLATE │ ├── bug_report.md │ └── enhancement-idea.md ├── .gitignore ├── AUTHORS ├── COPYING ├── ChangeLog ├── INSTALL ├── LICENSE ├── LICENSE.dwl ├── LICENSE.dwm ├── LICENSE.sway ├── LICENSE.tinywl ├── Makefile.am ├── NEWS ├── README ├── bin └── gwwm.in ├── buffer.c ├── build-aux └── test-driver.scm ├── channels-lock.scm ├── channels.scm ├── configure.ac ├── guix.scm ├── gwwm.scm ├── gwwm ├── buffer.scm ├── client.scm ├── color.scm ├── commands.scm ├── config.scm ├── configuration.scm.in ├── hooks.scm ├── i18n.scm ├── keybind.scm ├── keyboard.scm ├── keymap.scm ├── keys.scm ├── layout.scm ├── layout │ ├── monocle.scm │ └── tile.scm ├── listener.scm ├── monitor.scm ├── packages │ └── fullscreen-bg.scm ├── pointer.scm ├── popup.scm ├── touch.scm ├── user.scm ├── utils.scm ├── utils │ ├── ref.scm │ └── srfi-215.scm ├── web.scm └── x-client.scm ├── manifest.scm ├── po ├── LINGUAS ├── Makefile.in.in ├── Makevars ├── POTFILES.in ├── gwwm.pot └── zh_CN.po ├── pre-inst-env.in ├── protocols ├── idle.xml └── wlr-layer-shell-unstable-v1.xml ├── tests ├── config.scm ├── keymap.scm ├── utils.scm └── utils │ └── ref.scm ├── util.c └── util.h /.dir-locals.el: -------------------------------------------------------------------------------- 1 | ;;; Directory Local Variables -*- no-byte-compile: t -*- 2 | ;;; For more information see (info "(emacs) Directory Variables") 3 | 4 | ((scheme-mode . ((eval . (put 'let-slots 'scheme-indent-function 2))))) 5 | -------------------------------------------------------------------------------- /.github/ISSUE_TEMPLATE/bug_report.md: -------------------------------------------------------------------------------- 1 | --- 2 | name: Bug report 3 | about: Something in gwwm isn't working correctly 4 | title: '' 5 | labels: 'A: bug' 6 | assignees: '' 7 | 8 | --- 9 | 10 | ## Info 11 | gwwm's commit: 12 | guile-wlroots's commit: 13 | guile-wayland's commit: 14 | guile version: 15 | wlroots version: 16 | OS: 17 | log file: 18 | ## Description 19 | 20 | -------------------------------------------------------------------------------- /.github/ISSUE_TEMPLATE/enhancement-idea.md: -------------------------------------------------------------------------------- 1 | --- 2 | name: Enhancement idea 3 | about: Suggest a feature or improvement 4 | title: '' 5 | labels: 'A: enhancement' 6 | assignees: '' 7 | 8 | --- 9 | 10 | 11 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | /.ccls-cache/ 2 | /.deps/ 3 | /bin/gwwm 4 | idle-protocol.h 5 | wlr-layer-shell-unstable-v1-protocol.h 6 | xdg-shell-protocol.h 7 | *.o 8 | *.x 9 | *.eps 10 | *.go 11 | *.log 12 | *.pdf 13 | *.png 14 | *.tar.xz 15 | *.tar.gz 16 | *.tmp 17 | *~ 18 | .#* 19 | \#*\# 20 | ,* 21 | /ABOUT-NLS 22 | /INSTALL 23 | /aclocal.m4 24 | /autom4te.cache 25 | /build-aux/ar-lib 26 | /build-aux/compile 27 | po/Makefile 28 | po/Makevars.template 29 | *.gmo 30 | *.la 31 | *.lo 32 | libtool 33 | build-aux/ 34 | .libs/ 35 | gwwm/configuration.scm 36 | po/POTFILES 37 | po/Rules-quot 38 | po/boldquot.sed 39 | po/en@boldquot.header 40 | po/en@quot.header 41 | po/insert-header.sin 42 | po/quot.sed 43 | po/remove-potcdate.sin 44 | po/stamp-po 45 | /build-aux/config.guess 46 | /build-aux/config.rpath 47 | /build-aux/config.sub 48 | /build-aux/depcomp 49 | /build-aux/install-sh 50 | /build-aux/mdate-sh 51 | /build-aux/missing 52 | /build-aux/test-driver 53 | /build-aux/texinfo.tex 54 | /config.status 55 | /configure 56 | /doc/*.1 57 | /doc/.dirstamp 58 | /doc/contributing.*.texi 59 | /doc/*.aux 60 | /doc/*.cp 61 | /doc/*.cps 62 | /doc/*.fn 63 | /doc/*.fns 64 | /doc/*.html 65 | /doc/*.info 66 | /doc/*.info-[0-9] 67 | /doc/*.ky 68 | /doc/*.pg 69 | /doc/*.toc 70 | /doc/*.t2p 71 | /doc/*.tp 72 | /doc/*.vr 73 | /doc/*.vrs 74 | /doc/stamp-vti 75 | /doc/version.texi 76 | /doc/version-*.texi 77 | /m4/* 78 | /pre-inst-env 79 | /test-env 80 | /test-tmp 81 | /tests/*.trs 82 | GPATH 83 | GRTAGS 84 | GTAGS 85 | /Makefile 86 | Makefile.in 87 | config.cache 88 | stamp-h[0-9] 89 | tmp 90 | /.version 91 | /doc/stamp-[0-9] 92 | /magic/config.scm -------------------------------------------------------------------------------- /AUTHORS: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/Z572/gwwm/37596a6b31c3dc150367ed8803301b08dc046dcb/AUTHORS -------------------------------------------------------------------------------- /ChangeLog: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/Z572/gwwm/37596a6b31c3dc150367ed8803301b08dc046dcb/ChangeLog -------------------------------------------------------------------------------- /INSTALL: -------------------------------------------------------------------------------- 1 | Installation Instructions 2 | ************************* 3 | 4 | Copyright (C) 1994-1996, 1999-2002, 2004-2017, 2020-2021 Free 5 | Software Foundation, Inc. 6 | 7 | Copying and distribution of this file, with or without modification, 8 | are permitted in any medium without royalty provided the copyright 9 | notice and this notice are preserved. This file is offered as-is, 10 | without warranty of any kind. 11 | 12 | Basic Installation 13 | ================== 14 | 15 | Briefly, the shell command './configure && make && make install' 16 | should configure, build, and install this package. The following 17 | more-detailed instructions are generic; see the 'README' file for 18 | instructions specific to this package. Some packages provide this 19 | 'INSTALL' file but do not implement all of the features documented 20 | below. The lack of an optional feature in a given package is not 21 | necessarily a bug. More recommendations for GNU packages can be found 22 | in *note Makefile Conventions: (standards)Makefile Conventions. 23 | 24 | The 'configure' shell script attempts to guess correct values for 25 | various system-dependent variables used during compilation. It uses 26 | those values to create a 'Makefile' in each directory of the package. 27 | It may also create one or more '.h' files containing system-dependent 28 | definitions. Finally, it creates a shell script 'config.status' that 29 | you can run in the future to recreate the current configuration, and a 30 | file 'config.log' containing compiler output (useful mainly for 31 | debugging 'configure'). 32 | 33 | It can also use an optional file (typically called 'config.cache' and 34 | enabled with '--cache-file=config.cache' or simply '-C') that saves the 35 | results of its tests to speed up reconfiguring. Caching is disabled by 36 | default to prevent problems with accidental use of stale cache files. 37 | 38 | If you need to do unusual things to compile the package, please try 39 | to figure out how 'configure' could check whether to do them, and mail 40 | diffs or instructions to the address given in the 'README' so they can 41 | be considered for the next release. If you are using the cache, and at 42 | some point 'config.cache' contains results you don't want to keep, you 43 | may remove or edit it. 44 | 45 | The file 'configure.ac' (or 'configure.in') is used to create 46 | 'configure' by a program called 'autoconf'. You need 'configure.ac' if 47 | you want to change it or regenerate 'configure' using a newer version of 48 | 'autoconf'. 49 | 50 | The simplest way to compile this package is: 51 | 52 | 1. 'cd' to the directory containing the package's source code and type 53 | './configure' to configure the package for your system. 54 | 55 | Running 'configure' might take a while. While running, it prints 56 | some messages telling which features it is checking for. 57 | 58 | 2. Type 'make' to compile the package. 59 | 60 | 3. Optionally, type 'make check' to run any self-tests that come with 61 | the package, generally using the just-built uninstalled binaries. 62 | 63 | 4. Type 'make install' to install the programs and any data files and 64 | documentation. When installing into a prefix owned by root, it is 65 | recommended that the package be configured and built as a regular 66 | user, and only the 'make install' phase executed with root 67 | privileges. 68 | 69 | 5. Optionally, type 'make installcheck' to repeat any self-tests, but 70 | this time using the binaries in their final installed location. 71 | This target does not install anything. Running this target as a 72 | regular user, particularly if the prior 'make install' required 73 | root privileges, verifies that the installation completed 74 | correctly. 75 | 76 | 6. You can remove the program binaries and object files from the 77 | source code directory by typing 'make clean'. To also remove the 78 | files that 'configure' created (so you can compile the package for 79 | a different kind of computer), type 'make distclean'. There is 80 | also a 'make maintainer-clean' target, but that is intended mainly 81 | for the package's developers. If you use it, you may have to get 82 | all sorts of other programs in order to regenerate files that came 83 | with the distribution. 84 | 85 | 7. Often, you can also type 'make uninstall' to remove the installed 86 | files again. In practice, not all packages have tested that 87 | uninstallation works correctly, even though it is required by the 88 | GNU Coding Standards. 89 | 90 | 8. Some packages, particularly those that use Automake, provide 'make 91 | distcheck', which can by used by developers to test that all other 92 | targets like 'make install' and 'make uninstall' work correctly. 93 | This target is generally not run by end users. 94 | 95 | Compilers and Options 96 | ===================== 97 | 98 | Some systems require unusual options for compilation or linking that 99 | the 'configure' script does not know about. Run './configure --help' 100 | for details on some of the pertinent environment variables. 101 | 102 | You can give 'configure' initial values for configuration parameters 103 | by setting variables in the command line or in the environment. Here is 104 | an example: 105 | 106 | ./configure CC=c99 CFLAGS=-g LIBS=-lposix 107 | 108 | *Note Defining Variables::, for more details. 109 | 110 | Compiling For Multiple Architectures 111 | ==================================== 112 | 113 | You can compile the package for more than one kind of computer at the 114 | same time, by placing the object files for each architecture in their 115 | own directory. To do this, you can use GNU 'make'. 'cd' to the 116 | directory where you want the object files and executables to go and run 117 | the 'configure' script. 'configure' automatically checks for the source 118 | code in the directory that 'configure' is in and in '..'. This is known 119 | as a "VPATH" build. 120 | 121 | With a non-GNU 'make', it is safer to compile the package for one 122 | architecture at a time in the source code directory. After you have 123 | installed the package for one architecture, use 'make distclean' before 124 | reconfiguring for another architecture. 125 | 126 | On MacOS X 10.5 and later systems, you can create libraries and 127 | executables that work on multiple system types--known as "fat" or 128 | "universal" binaries--by specifying multiple '-arch' options to the 129 | compiler but only a single '-arch' option to the preprocessor. Like 130 | this: 131 | 132 | ./configure CC="gcc -arch i386 -arch x86_64 -arch ppc -arch ppc64" \ 133 | CXX="g++ -arch i386 -arch x86_64 -arch ppc -arch ppc64" \ 134 | CPP="gcc -E" CXXCPP="g++ -E" 135 | 136 | This is not guaranteed to produce working output in all cases, you 137 | may have to build one architecture at a time and combine the results 138 | using the 'lipo' tool if you have problems. 139 | 140 | Installation Names 141 | ================== 142 | 143 | By default, 'make install' installs the package's commands under 144 | '/usr/local/bin', include files under '/usr/local/include', etc. You 145 | can specify an installation prefix other than '/usr/local' by giving 146 | 'configure' the option '--prefix=PREFIX', where PREFIX must be an 147 | absolute file name. 148 | 149 | You can specify separate installation prefixes for 150 | architecture-specific files and architecture-independent files. If you 151 | pass the option '--exec-prefix=PREFIX' to 'configure', the package uses 152 | PREFIX as the prefix for installing programs and libraries. 153 | Documentation and other data files still use the regular prefix. 154 | 155 | In addition, if you use an unusual directory layout you can give 156 | options like '--bindir=DIR' to specify different values for particular 157 | kinds of files. Run 'configure --help' for a list of the directories 158 | you can set and what kinds of files go in them. In general, the default 159 | for these options is expressed in terms of '${prefix}', so that 160 | specifying just '--prefix' will affect all of the other directory 161 | specifications that were not explicitly provided. 162 | 163 | The most portable way to affect installation locations is to pass the 164 | correct locations to 'configure'; however, many packages provide one or 165 | both of the following shortcuts of passing variable assignments to the 166 | 'make install' command line to change installation locations without 167 | having to reconfigure or recompile. 168 | 169 | The first method involves providing an override variable for each 170 | affected directory. For example, 'make install 171 | prefix=/alternate/directory' will choose an alternate location for all 172 | directory configuration variables that were expressed in terms of 173 | '${prefix}'. Any directories that were specified during 'configure', 174 | but not in terms of '${prefix}', must each be overridden at install time 175 | for the entire installation to be relocated. The approach of makefile 176 | variable overrides for each directory variable is required by the GNU 177 | Coding Standards, and ideally causes no recompilation. However, some 178 | platforms have known limitations with the semantics of shared libraries 179 | that end up requiring recompilation when using this method, particularly 180 | noticeable in packages that use GNU Libtool. 181 | 182 | The second method involves providing the 'DESTDIR' variable. For 183 | example, 'make install DESTDIR=/alternate/directory' will prepend 184 | '/alternate/directory' before all installation names. The approach of 185 | 'DESTDIR' overrides is not required by the GNU Coding Standards, and 186 | does not work on platforms that have drive letters. On the other hand, 187 | it does better at avoiding recompilation issues, and works well even 188 | when some directory options were not specified in terms of '${prefix}' 189 | at 'configure' time. 190 | 191 | Optional Features 192 | ================= 193 | 194 | If the package supports it, you can cause programs to be installed 195 | with an extra prefix or suffix on their names by giving 'configure' the 196 | option '--program-prefix=PREFIX' or '--program-suffix=SUFFIX'. 197 | 198 | Some packages pay attention to '--enable-FEATURE' options to 199 | 'configure', where FEATURE indicates an optional part of the package. 200 | They may also pay attention to '--with-PACKAGE' options, where PACKAGE 201 | is something like 'gnu-as' or 'x' (for the X Window System). The 202 | 'README' should mention any '--enable-' and '--with-' options that the 203 | package recognizes. 204 | 205 | For packages that use the X Window System, 'configure' can usually 206 | find the X include and library files automatically, but if it doesn't, 207 | you can use the 'configure' options '--x-includes=DIR' and 208 | '--x-libraries=DIR' to specify their locations. 209 | 210 | Some packages offer the ability to configure how verbose the 211 | execution of 'make' will be. For these packages, running './configure 212 | --enable-silent-rules' sets the default to minimal output, which can be 213 | overridden with 'make V=1'; while running './configure 214 | --disable-silent-rules' sets the default to verbose, which can be 215 | overridden with 'make V=0'. 216 | 217 | Particular systems 218 | ================== 219 | 220 | On HP-UX, the default C compiler is not ANSI C compatible. If GNU CC 221 | is not installed, it is recommended to use the following options in 222 | order to use an ANSI C compiler: 223 | 224 | ./configure CC="cc -Ae -D_XOPEN_SOURCE=500" 225 | 226 | and if that doesn't work, install pre-built binaries of GCC for HP-UX. 227 | 228 | HP-UX 'make' updates targets which have the same timestamps as their 229 | prerequisites, which makes it generally unusable when shipped generated 230 | files such as 'configure' are involved. Use GNU 'make' instead. 231 | 232 | On OSF/1 a.k.a. Tru64, some versions of the default C compiler cannot 233 | parse its '' header file. The option '-nodtk' can be used as a 234 | workaround. If GNU CC is not installed, it is therefore recommended to 235 | try 236 | 237 | ./configure CC="cc" 238 | 239 | and if that doesn't work, try 240 | 241 | ./configure CC="cc -nodtk" 242 | 243 | On Solaris, don't put '/usr/ucb' early in your 'PATH'. This 244 | directory contains several dysfunctional programs; working variants of 245 | these programs are available in '/usr/bin'. So, if you need '/usr/ucb' 246 | in your 'PATH', put it _after_ '/usr/bin'. 247 | 248 | On Haiku, software installed for all users goes in '/boot/common', 249 | not '/usr/local'. It is recommended to use the following options: 250 | 251 | ./configure --prefix=/boot/common 252 | 253 | Specifying the System Type 254 | ========================== 255 | 256 | There may be some features 'configure' cannot figure out 257 | automatically, but needs to determine by the type of machine the package 258 | will run on. Usually, assuming the package is built to be run on the 259 | _same_ architectures, 'configure' can figure that out, but if it prints 260 | a message saying it cannot guess the machine type, give it the 261 | '--build=TYPE' option. TYPE can either be a short name for the system 262 | type, such as 'sun4', or a canonical name which has the form: 263 | 264 | CPU-COMPANY-SYSTEM 265 | 266 | where SYSTEM can have one of these forms: 267 | 268 | OS 269 | KERNEL-OS 270 | 271 | See the file 'config.sub' for the possible values of each field. If 272 | 'config.sub' isn't included in this package, then this package doesn't 273 | need to know the machine type. 274 | 275 | If you are _building_ compiler tools for cross-compiling, you should 276 | use the option '--target=TYPE' to select the type of system they will 277 | produce code for. 278 | 279 | If you want to _use_ a cross compiler, that generates code for a 280 | platform different from the build platform, you should specify the 281 | "host" platform (i.e., that on which the generated programs will 282 | eventually be run) with '--host=TYPE'. 283 | 284 | Sharing Defaults 285 | ================ 286 | 287 | If you want to set default values for 'configure' scripts to share, 288 | you can create a site shell script called 'config.site' that gives 289 | default values for variables like 'CC', 'cache_file', and 'prefix'. 290 | 'configure' looks for 'PREFIX/share/config.site' if it exists, then 291 | 'PREFIX/etc/config.site' if it exists. Or, you can set the 292 | 'CONFIG_SITE' environment variable to the location of the site script. 293 | A warning: not all 'configure' scripts look for a site script. 294 | 295 | Defining Variables 296 | ================== 297 | 298 | Variables not defined in a site shell script can be set in the 299 | environment passed to 'configure'. However, some packages may run 300 | configure again during the build, and the customized values of these 301 | variables may be lost. In order to avoid this problem, you should set 302 | them in the 'configure' command line, using 'VAR=value'. For example: 303 | 304 | ./configure CC=/usr/local2/bin/gcc 305 | 306 | causes the specified 'gcc' to be used as the C compiler (unless it is 307 | overridden in the site shell script). 308 | 309 | Unfortunately, this technique does not work for 'CONFIG_SHELL' due to an 310 | Autoconf limitation. Until the limitation is lifted, you can use this 311 | workaround: 312 | 313 | CONFIG_SHELL=/bin/bash ./configure CONFIG_SHELL=/bin/bash 314 | 315 | 'configure' Invocation 316 | ====================== 317 | 318 | 'configure' recognizes the following options to control how it 319 | operates. 320 | 321 | '--help' 322 | '-h' 323 | Print a summary of all of the options to 'configure', and exit. 324 | 325 | '--help=short' 326 | '--help=recursive' 327 | Print a summary of the options unique to this package's 328 | 'configure', and exit. The 'short' variant lists options used only 329 | in the top level, while the 'recursive' variant lists options also 330 | present in any nested packages. 331 | 332 | '--version' 333 | '-V' 334 | Print the version of Autoconf used to generate the 'configure' 335 | script, and exit. 336 | 337 | '--cache-file=FILE' 338 | Enable the cache: use and save the results of the tests in FILE, 339 | traditionally 'config.cache'. FILE defaults to '/dev/null' to 340 | disable caching. 341 | 342 | '--config-cache' 343 | '-C' 344 | Alias for '--cache-file=config.cache'. 345 | 346 | '--quiet' 347 | '--silent' 348 | '-q' 349 | Do not print messages saying which checks are being made. To 350 | suppress all normal output, redirect it to '/dev/null' (any error 351 | messages will still be shown). 352 | 353 | '--srcdir=DIR' 354 | Look for the package's source code in directory DIR. Usually 355 | 'configure' can determine that directory automatically. 356 | 357 | '--prefix=DIR' 358 | Use DIR as the installation prefix. *note Installation Names:: for 359 | more details, including other options available for fine-tuning the 360 | installation locations. 361 | 362 | '--no-create' 363 | '-n' 364 | Run the configure checks, but stop before creating any output 365 | files. 366 | 367 | 'configure' also accepts some other, not widely useful, options. Run 368 | 'configure --help' for more details. 369 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | COPYING -------------------------------------------------------------------------------- /LICENSE.dwm: -------------------------------------------------------------------------------- 1 | Portions of dwl based on dwm code are used under the following license: 2 | 3 | MIT/X Consortium License 4 | 5 | © 2006-2019 Anselm R Garbe 6 | © 2006-2009 Jukka Salmi 7 | © 2006-2007 Sander van Dijk 8 | © 2007-2011 Peter Hartlich 9 | © 2007-2009 Szabolcs Nagy 10 | © 2007-2009 Christof Musik 11 | © 2007-2009 Premysl Hruby 12 | © 2007-2008 Enno Gottox Boland 13 | © 2008 Martin Hurton 14 | © 2008 Neale Pickett 15 | © 2009 Mate Nagy 16 | © 2010-2016 Hiltjo Posthuma 17 | © 2010-2012 Connor Lane Smith 18 | © 2011 Christoph Lohmann <20h@r-36.net> 19 | © 2015-2016 Quentin Rameau 20 | © 2015-2016 Eric Pruitt 21 | © 2016-2017 Markus Teich 22 | 23 | Permission is hereby granted, free of charge, to any person obtaining a 24 | copy of this software and associated documentation files (the "Software"), 25 | to deal in the Software without restriction, including without limitation 26 | the rights to use, copy, modify, merge, publish, distribute, sublicense, 27 | and/or sell copies of the Software, and to permit persons to whom the 28 | Software is furnished to do so, subject to the following conditions: 29 | 30 | The above copyright notice and this permission notice shall be included in 31 | all copies or substantial portions of the Software. 32 | 33 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 34 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 35 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL 36 | THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 37 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 38 | FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 39 | DEALINGS IN THE SOFTWARE. 40 | -------------------------------------------------------------------------------- /LICENSE.sway: -------------------------------------------------------------------------------- 1 | Copyright (c) 2016-2017 Drew DeVault 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 | -------------------------------------------------------------------------------- /LICENSE.tinywl: -------------------------------------------------------------------------------- 1 | dwl is originally based on TinyWL, which is used under the following license: 2 | 3 | This work is licensed under CC0, which effectively puts it in the public domain. 4 | 5 | --- 6 | 7 | Creative Commons Legal Code 8 | 9 | CC0 1.0 Universal 10 | 11 | CREATIVE COMMONS CORPORATION IS NOT A LAW FIRM AND DOES NOT PROVIDE 12 | LEGAL SERVICES. DISTRIBUTION OF THIS DOCUMENT DOES NOT CREATE AN 13 | ATTORNEY-CLIENT RELATIONSHIP. CREATIVE COMMONS PROVIDES THIS 14 | INFORMATION ON AN "AS-IS" BASIS. CREATIVE COMMONS MAKES NO WARRANTIES 15 | REGARDING THE USE OF THIS DOCUMENT OR THE INFORMATION OR WORKS 16 | PROVIDED HEREUNDER, AND DISCLAIMS LIABILITY FOR DAMAGES RESULTING FROM 17 | THE USE OF THIS DOCUMENT OR THE INFORMATION OR WORKS PROVIDED 18 | HEREUNDER. 19 | 20 | Statement of Purpose 21 | 22 | The laws of most jurisdictions throughout the world automatically confer 23 | exclusive Copyright and Related Rights (defined below) upon the creator 24 | and subsequent owner(s) (each and all, an "owner") of an original work of 25 | authorship and/or a database (each, a "Work"). 26 | 27 | Certain owners wish to permanently relinquish those rights to a Work for 28 | the purpose of contributing to a commons of creative, cultural and 29 | scientific works ("Commons") that the public can reliably and without fear 30 | of later claims of infringement build upon, modify, incorporate in other 31 | works, reuse and redistribute as freely as possible in any form whatsoever 32 | and for any purposes, including without limitation commercial purposes. 33 | These owners may contribute to the Commons to promote the ideal of a free 34 | culture and the further production of creative, cultural and scientific 35 | works, or to gain reputation or greater distribution for their Work in 36 | part through the use and efforts of others. 37 | 38 | For these and/or other purposes and motivations, and without any 39 | expectation of additional consideration or compensation, the person 40 | associating CC0 with a Work (the "Affirmer"), to the extent that he or she 41 | is an owner of Copyright and Related Rights in the Work, voluntarily 42 | elects to apply CC0 to the Work and publicly distribute the Work under its 43 | terms, with knowledge of his or her Copyright and Related Rights in the 44 | Work and the meaning and intended legal effect of CC0 on those rights. 45 | 46 | 1. Copyright and Related Rights. A Work made available under CC0 may be 47 | protected by copyright and related or neighboring rights ("Copyright and 48 | Related Rights"). Copyright and Related Rights include, but are not 49 | limited to, the following: 50 | 51 | i. the right to reproduce, adapt, distribute, perform, display, 52 | communicate, and translate a Work; 53 | ii. moral rights retained by the original author(s) and/or performer(s); 54 | iii. publicity and privacy rights pertaining to a person's image or 55 | likeness depicted in a Work; 56 | iv. rights protecting against unfair competition in regards to a Work, 57 | subject to the limitations in paragraph 4(a), below; 58 | v. rights protecting the extraction, dissemination, use and reuse of data 59 | in a Work; 60 | vi. database rights (such as those arising under Directive 96/9/EC of the 61 | European Parliament and of the Council of 11 March 1996 on the legal 62 | protection of databases, and under any national implementation 63 | thereof, including any amended or successor version of such 64 | directive); and 65 | vii. other similar, equivalent or corresponding rights throughout the 66 | world based on applicable law or treaty, and any national 67 | implementations thereof. 68 | 69 | 2. Waiver. To the greatest extent permitted by, but not in contravention 70 | of, applicable law, Affirmer hereby overtly, fully, permanently, 71 | irrevocably and unconditionally waives, abandons, and surrenders all of 72 | Affirmer's Copyright and Related Rights and associated claims and causes 73 | of action, whether now known or unknown (including existing as well as 74 | future claims and causes of action), in the Work (i) in all territories 75 | worldwide, (ii) for the maximum duration provided by applicable law or 76 | treaty (including future time extensions), (iii) in any current or future 77 | medium and for any number of copies, and (iv) for any purpose whatsoever, 78 | including without limitation commercial, advertising or promotional 79 | purposes (the "Waiver"). Affirmer makes the Waiver for the benefit of each 80 | member of the public at large and to the detriment of Affirmer's heirs and 81 | successors, fully intending that such Waiver shall not be subject to 82 | revocation, rescission, cancellation, termination, or any other legal or 83 | equitable action to disrupt the quiet enjoyment of the Work by the public 84 | as contemplated by Affirmer's express Statement of Purpose. 85 | 86 | 3. Public License Fallback. Should any part of the Waiver for any reason 87 | be judged legally invalid or ineffective under applicable law, then the 88 | Waiver shall be preserved to the maximum extent permitted taking into 89 | account Affirmer's express Statement of Purpose. In addition, to the 90 | extent the Waiver is so judged Affirmer hereby grants to each affected 91 | person a royalty-free, non transferable, non sublicensable, non exclusive, 92 | irrevocable and unconditional license to exercise Affirmer's Copyright and 93 | Related Rights in the Work (i) in all territories worldwide, (ii) for the 94 | maximum duration provided by applicable law or treaty (including future 95 | time extensions), (iii) in any current or future medium and for any number 96 | of copies, and (iv) for any purpose whatsoever, including without 97 | limitation commercial, advertising or promotional purposes (the 98 | "License"). The License shall be deemed effective as of the date CC0 was 99 | applied by Affirmer to the Work. Should any part of the License for any 100 | reason be judged legally invalid or ineffective under applicable law, such 101 | partial invalidity or ineffectiveness shall not invalidate the remainder 102 | of the License, and in such case Affirmer hereby affirms that he or she 103 | will not (i) exercise any of his or her remaining Copyright and Related 104 | Rights in the Work or (ii) assert any associated claims and causes of 105 | action with respect to the Work, in either case contrary to Affirmer's 106 | express Statement of Purpose. 107 | 108 | 4. Limitations and Disclaimers. 109 | 110 | a. No trademark or patent rights held by Affirmer are waived, abandoned, 111 | surrendered, licensed or otherwise affected by this document. 112 | b. Affirmer offers the Work as-is and makes no representations or 113 | warranties of any kind concerning the Work, express, implied, 114 | statutory or otherwise, including without limitation warranties of 115 | title, merchantability, fitness for a particular purpose, non 116 | infringement, or the absence of latent or other defects, accuracy, or 117 | the present or absence of errors, whether or not discoverable, all to 118 | the greatest extent permissible under applicable law. 119 | c. Affirmer disclaims responsibility for clearing rights of other persons 120 | that may apply to the Work or any use thereof, including without 121 | limitation any person's Copyright and Related Rights in the Work. 122 | Further, Affirmer disclaims responsibility for obtaining any necessary 123 | consents, permissions or other rights required for any use of the 124 | Work. 125 | d. Affirmer understands and acknowledges that Creative Commons is not a 126 | party to this document and has no duty or obligation with respect to 127 | this CC0 or use of the Work. 128 | -------------------------------------------------------------------------------- /Makefile.am: -------------------------------------------------------------------------------- 1 | AUTOMAKE_OPTIONS = gnu 2 | 3 | protocols_h = xdg-shell-protocol.h wlr-layer-shell-unstable-v1-protocol.h idle-protocol.h 4 | protocols= $(top_builddir)/protocols/wlr-layer-shell-unstable-v1.xml \ 5 | $(top_builddir)/protocols/idle.xml 6 | 7 | lib_LTLIBRARIES= libgwwm.la 8 | # bin_PROGRAMS= gwwm 9 | libgwwm_la_SOURCES= %D%/buffer.c \ 10 | %D%/util.h \ 11 | %D%/util.c \ 12 | %D%/config.h 13 | nodist_libgwwm_la_SOURCES = $(protocols_h) 14 | libgwwm_la_CFLAGS= $(WAYLAND_SERVER_CFLAGS) $(WLROOTS_CFLAGS) $(GUILE_CFLAGS) \ 15 | $(XCB_CFLAGS) $(XKBCOMMON_CFLAGS) $(LIBINPUT_CFLAGS) \ 16 | -I. -DWLR_USE_UNSTABLE -DXWAYLAND -Og -Wall -Wextra 17 | libgwwm_la_LIBADD= $(WLROOTS_LIBS) $(WAYLAND_SERVER_LIBS) $(XKBCOMMON_LIBS) \ 18 | $(GUILE_LIBS) $(LIBINPUT_LIBS) $(XCB_LIBS) 19 | snarfcppopts = $(INCLUDES) $(CPPFLAGS) $(libgwwm_la_CFLAGS) 20 | SUFFIXES= .c .scm .go .x .xml -protocol.h 21 | 22 | $(protocols_h): $(protocols) 23 | $(libgwwm_la_SOURCES): $(protocols_h) 24 | $(SOURCES): $(lib_LTLIBRARIES) 25 | .c.x: 26 | guile-snarf -o $@ $< $(snarfcppopts) 27 | CLEANFILES = %D%/*.x $(protocols_h) 28 | 29 | BUILT_SOURCES = %D%/buffer.x $(protocols_h) \ 30 | $(c_sources) 31 | xdg-shell-protocol.h: 32 | $(AM_V_GEN) $(WAYLAND_SCANNER) server-header \ 33 | $(WAYLAND_PROTOCOLS)/stable/xdg-shell/xdg-shell.xml $@ 34 | 35 | wlr-layer-shell-unstable-v1-protocol.h: 36 | $(AM_V_GEN) $(WAYLAND_SCANNER) server-header \ 37 | $(top_builddir)/protocols/wlr-layer-shell-unstable-v1.xml $@ 38 | 39 | idle-protocol.h: 40 | $(AM_V_GEN) $(WAYLAND_SCANNER) server-header \ 41 | $(top_builddir)/protocols/idle.xml $@ 42 | 43 | SUBDIRS=po 44 | do_subst = $(SED) \ 45 | -e 's,[@]GUILE[@],$(GUILE),g' \ 46 | -e 's,[@]guilemoduledir[@],$(guilemoduledir),g' \ 47 | -e 's,[@]guileobjectdir[@],$(guileobjectdir),g' \ 48 | -e 's,[@]localedir[@],$(localedir),g' 49 | 50 | EXTRA_DIST = $(SOURCES) $(protocols) 51 | 52 | 53 | # 54 | GOBJECTS = $(SOURCES:%.scm=%.go) $(NODIST_SOURCES:%.scm=%.go) 55 | moddir=$(guilemoduledir)/gwwm 56 | godir=$(guileobjectdir)/gwwm 57 | nobase_guilemodule_DATA = gwwm.scm \ 58 | gwwm/color.scm \ 59 | gwwm/monitor.scm \ 60 | gwwm/layout.scm \ 61 | gwwm/layout/tile.scm \ 62 | gwwm/layout/monocle.scm \ 63 | gwwm/client.scm \ 64 | gwwm/keymap.scm \ 65 | gwwm/keybind.scm \ 66 | gwwm/keyboard.scm \ 67 | gwwm/pointer.scm \ 68 | gwwm/web.scm \ 69 | gwwm/popup.scm \ 70 | gwwm/touch.scm \ 71 | gwwm/user.scm \ 72 | gwwm/buffer.scm \ 73 | gwwm/i18n.scm \ 74 | gwwm/hooks.scm \ 75 | gwwm/utils.scm \ 76 | gwwm/utils/srfi-215.scm \ 77 | gwwm/utils/ref.scm \ 78 | gwwm/keys.scm \ 79 | gwwm/listener.scm \ 80 | gwwm/commands.scm \ 81 | gwwm/packages/fullscreen-bg.scm \ 82 | gwwm/configuration.scm \ 83 | gwwm/config.scm 84 | 85 | dist_bin_SCRIPTS=bin/gwwm 86 | bin/gwwm: bin/gwwm.in Makefile 87 | $(AM_V_at)rm -f $@ $@-t 88 | $(AM_V_at)$(MKDIR_P) "$(@D)" 89 | $(AM_V_GEN)$(do_subst) < "$(srcdir)/$@.in" > "$@-t" 90 | $(AM_V_at)chmod a+x,a-w "$@-t" && mv -f "$@-t" "$@" 91 | 92 | # nobase_go_DATA = $(GOBJECTS) 93 | nobase_guileobject_DATA=$(nobase_guilemodule_DATA:%.scm=%.go) 94 | SOURCES=$(nobase_guilemodule_DATA) 95 | 96 | guile_install_go_files = install-nobase_guileobject_DATA 97 | $(guile_install_go_files): install-nobase_guilemodule_DATA 98 | 99 | CLEANFILES += $(GOBJECTS) 100 | GUILE_WARNINGS = \ 101 | -Wunbound-variable -Warity-mismatch -Wshadowed-toplevel \ 102 | -Wmacro-use-before-definition \ 103 | -Wunused-variable \ 104 | -Wduplicate-case-datum -Wbad-case-datum \ 105 | -Wformat 106 | 107 | .scm.go: 108 | $(AM_V_GEN)$(top_builddir)/pre-inst-env $(GUILE_TOOLS) compile $(GUILE_TARGET) $(GUILE_WARNINGS) -o "$@" "$<" 109 | .PHONY: run 110 | run: all 111 | GWWM_DEBUG=1 exec $(top_builddir)/pre-inst-env $(top_srcdir)/bin/gwwm 112 | 113 | TESTS = tests/config.scm tests/keymap.scm tests/utils.scm tests/utils/ref.scm 114 | TEST_EXTENSIONS = .scm 115 | SCM_LOG_DRIVER = \ 116 | $(top_builddir)/pre-inst-env \ 117 | $(GUILE) --no-auto-compile -e main \ 118 | $(top_srcdir)/build-aux/test-driver.scm 119 | AM_SCM_LOG_DRIVER_FLAGS = --brief=no 120 | AM_SCM_LOG_FLAGS = --no-auto-compile -L "$(top_srcdir)" 121 | AM_TESTS_ENVIRONMENT = abs_top_srcdir="$(abs_top_srcdir)" 122 | CLEANFILES += $(TESTS:tests/%.scm=%.log) 123 | 124 | gdb: all 125 | GWWM_DEBUG=1 exec $(top_builddir)/pre-inst-env gdb guile -ex "run $(top_builddir)/bin/gwwm" 126 | -------------------------------------------------------------------------------- /NEWS: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/Z572/gwwm/37596a6b31c3dc150367ed8803301b08dc046dcb/NEWS -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- 1 | # -*- mode: org -*- 2 | #+title: gwwm - guile wayland windows manager. 3 | 4 | fork from dwl, add guile to configure it. 5 | 6 | * WARN 7 | - Is a WIP project. 8 | - Both api changes and errors occur. 9 | - no xwayland for now 10 | 11 | * how to build 12 | you need 13 | - automake 14 | - autoconf 15 | - bash 16 | - guile 17 | - [[https://github.com/Z572/guile-wayland][guile-wayland]] 18 | - [[https://github.com/Z572/guile-wlroots][guile-wlroots]] 19 | - [[https://github.com/Z572/guile-libinput][guile-libinput]] 20 | - [[https://github.com/scheme-requests-for-implementation/srfi-189][srfi-189]] 21 | - [[https://github.com/Z572/util572][util572]] 22 | - [[https://www.nongnu.org/guile-cairo/][guile-cairo]] 23 | - pkg-config 24 | - texinfo 25 | - wlroots 26 | 27 | #+begin_src sh 28 | autoreconf -fiv 29 | ./configure 30 | make -j 31 | #+end_src 32 | 33 | * develop 34 | If you use emacs, you can use =geiser-connect= to connect gwwm. 35 | 36 | If you use guix: 37 | #+begin_src sh 38 | git clone https://github.com/Z572/gwwm 39 | git clone https://github.com/Z572/guile-wayland 40 | git clone https://github.com/Z572/guile-wlroots 41 | git clone https://github.com/Z572/util572 42 | cd gwwm 43 | guix time-machine --channels=channels-lock.scm -- shell -D -f guix.scm 44 | autoreconf -fiv 45 | ./configure 46 | make -j 47 | make run 48 | #+end_src 49 | 50 | * configure 51 | simple example 52 | ~/.config/gwwm/init.scm: 53 | #+begin_src scheme 54 | (use-modules (gwwm) 55 | (gwwm config) 56 | (gwwm commands) 57 | (gwwm keymap) 58 | (gwwm hooks) 59 | (gwwm color)) 60 | ;;; win+d 61 | (keymap-global-set (kbd (s d)) (lambda () (spawn "firefox" '("firefox")))) 62 | (gwwm 63 | (borderpx 1) 64 | (sloppyfocus? #t) 65 | (xkb-rules 66 | (make-xkb-rules 67 | "us" 68 | #:model "asus_laptop" 69 | #:options 70 | '("ctrl:ralt_rctrl" 71 | "ctrl:swapcaps_hyper" 72 | "shift:both_capslock"))) 73 | (bordercolor (make-color "#ffbbeeff"))) 74 | 75 | #+end_src 76 | 77 | 78 | * thanks 79 | Thanks of guile, dwl , tinywl ,sway. 80 | -------------------------------------------------------------------------------- /bin/gwwm.in: -------------------------------------------------------------------------------- 1 | #!@GUILE@ 2 | !# 3 | (use-modules (gwwm)) 4 | 5 | (bindtextdomain "gwwm" "@localedir@") 6 | (apply main (command-line)) 7 | ;;; Local Variables: 8 | ;;; mode: scheme 9 | ;;; End: 10 | -------------------------------------------------------------------------------- /buffer.c: -------------------------------------------------------------------------------- 1 | #include "libguile/eval.h" 2 | #include "libguile/foreign-object.h" 3 | #include "libguile/foreign.h" 4 | #include "libguile/goops.h" 5 | #include "libguile/numbers.h" 6 | #include "libguile/scm.h" 7 | #include "libguile/symbols.h" 8 | #include "util.h" 9 | #include "wayland-util.h" 10 | #include 11 | #include 12 | #include 13 | #include 14 | #include 15 | #include 16 | #include 17 | 18 | struct gwwm_buffer { 19 | struct wlr_buffer base; 20 | SCM scm; 21 | SCM surface; 22 | SCM cairo; 23 | SCM format; 24 | }; 25 | 26 | static void gwwm_buffer_destroy(struct wlr_buffer *wlr_buffer) { 27 | struct gwwm_buffer *buffer = wl_container_of(wlr_buffer, buffer, base); 28 | buffer->scm = NULL; 29 | scm_gc_unprotect_object(buffer->cairo); 30 | buffer->cairo = NULL; 31 | scm_gc_unprotect_object(buffer->surface); 32 | buffer->surface=NULL; 33 | buffer->format=NULL; 34 | free(buffer); 35 | } 36 | static bool gwwm_buffer_begin_data_ptr_access(struct wlr_buffer *wlr_buffer, 37 | uint32_t flags, void **data, 38 | uint32_t *format, 39 | size_t *stride) { 40 | struct gwwm_buffer *buffer = wl_container_of(wlr_buffer, buffer, base); 41 | SCM ssurface =buffer->surface; 42 | *data = (TO_P(REF_CALL_1( 43 | "system foreign", "bytevector->pointer", 44 | (REF_CALL_1("cairo", "cairo-image-surface-get-data", ssurface))))); 45 | 46 | *format = (scm_to_uint32(buffer->format)); 47 | *stride = (scm_to_double( 48 | REF_CALL_1("cairo", "cairo-image-surface-get-stride", ssurface))); 49 | return true; 50 | } 51 | 52 | static void gwwm_buffer_end_data_ptr_access(struct wlr_buffer *wlr_buffer) {} 53 | static const struct wlr_buffer_impl gwwm_buffer_impl = { 54 | .destroy = gwwm_buffer_destroy, 55 | .begin_data_ptr_access = gwwm_buffer_begin_data_ptr_access, 56 | .end_data_ptr_access = gwwm_buffer_end_data_ptr_access}; 57 | 58 | static struct gwwm_buffer *gwwm_buffer_create(int width, int height) { 59 | struct gwwm_buffer *buffer = scm_calloc(sizeof(*buffer)); 60 | if (buffer == NULL) { 61 | return NULL; 62 | } 63 | 64 | wlr_buffer_init(&buffer->base, &gwwm_buffer_impl, width, height); 65 | SCM ssurface = REF_CALL_3("cairo", "cairo-image-surface-create", 66 | scm_from_utf8_symbol("argb32"), scm_from_int(width), 67 | scm_from_int(height)); 68 | buffer->scm = (scm_call_3( 69 | REF("oop goops", "make"), REFP("gwwm buffer", ""), 70 | scm_from_utf8_keyword("data"), FROM_P(buffer))); 71 | buffer->cairo=REF_CALL_1("cairo", "cairo-create", ssurface); 72 | buffer->surface=ssurface; 73 | buffer->format=scm_from_unsigned_integer(DRM_FORMAT_ARGB8888); 74 | scm_gc_protect_object(ssurface); 75 | scm_gc_protect_object(buffer->cairo); 76 | return buffer; 77 | } 78 | 79 | SCM_DEFINE(cairo_buffer_create, "cairo-buffer-create", 2, 0, 0, 80 | (SCM width, SCM height), "") { 81 | return (gwwm_buffer_create(scm_to_int(width), scm_to_int(height)))->scm; 82 | } 83 | 84 | SCM_DEFINE(cairo_buffer_base, "cairo-buffer-base", 1, 0, 0, (SCM buffer), "") { 85 | return WRAP_WLR_BUFFER(&((struct gwwm_buffer *)(TO_P(scm_slot_ref( 86 | buffer, scm_from_utf8_symbol("%data"))))) 87 | ->base); 88 | } 89 | 90 | SCM_DEFINE(cairo_buffer_cairo, "cairo-buffer-cairo", 1, 0, 0, (SCM buffer), "") { 91 | return ((struct gwwm_buffer *)(TO_P(scm_slot_ref( 92 | buffer, scm_from_utf8_symbol("%data")))))->cairo; 93 | } 94 | 95 | SCM_DEFINE(set_cairo_buffer_base, "set-cairo-buffer-base!", 2, 0, 0, 96 | (SCM buffer, SCM wlr_buffer), "") { 97 | ((struct gwwm_buffer *)(TO_P( 98 | scm_slot_ref(buffer, scm_from_utf8_symbol("%data"))))) 99 | ->base = *((struct wlr_buffer *)(UNWRAP_WLR_BUFFER(wlr_buffer))); 100 | return SCM_UNSPECIFIED; 101 | } 102 | void scm_init_gwwm_buffer(void) { 103 | #ifndef SCM_MAGIC_SNARFER 104 | #include "buffer.x" 105 | #endif 106 | } 107 | -------------------------------------------------------------------------------- /build-aux/test-driver.scm: -------------------------------------------------------------------------------- 1 | 2 | ;;;; test-driver.scm - Guile test driver for Automake testsuite harness 3 | 4 | (define script-version "2019-01-15.13") ;UTC 5 | 6 | ;;; Copyright © 2015, 2016 Mathieu Lirzin 7 | ;;; Copyright © 2019 Alex Sassmannshausen 8 | ;;; 9 | ;;; This program is free software; you can redistribute it and/or modify it 10 | ;;; under the terms of the GNU General Public License as published by 11 | ;;; the Free Software Foundation; either version 3 of the License, or (at 12 | ;;; your option) any later version. 13 | ;;; 14 | ;;; This program is distributed in the hope that it will be useful, but 15 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of 16 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 17 | ;;; GNU General Public License for more details. 18 | ;;; 19 | ;;; You should have received a copy of the GNU General Public License 20 | ;;; along with this program. If not, see . 21 | 22 | ;;;; Commentary: 23 | ;;; 24 | ;;; This script provides a Guile test driver using the SRFI-64 Scheme API for 25 | ;;; test suites. SRFI-64 is distributed with Guile since version 2.0.9. 26 | ;;; 27 | ;;; This script is a lightly modified version of the orignal written by 28 | ;;; Matthieu Lirzin. The changes make it suitable for use as part of the 29 | ;;; guile-hall infrastructure. 30 | ;;; 31 | ;;;; Code: 32 | 33 | (use-modules (ice-9 getopt-long) 34 | (ice-9 pretty-print) 35 | (srfi srfi-26) 36 | (srfi srfi-64)) 37 | 38 | (define (show-help) 39 | (display "Usage: 40 | test-driver --test-name=NAME --log-file=PATH --trs-file=PATH 41 | [--expect-failure={yes|no}] [--color-tests={yes|no}] 42 | [--enable-hard-errors={yes|no}] [--brief={yes|no}}] [--] 43 | TEST-SCRIPT [TEST-SCRIPT-ARGUMENTS] 44 | The '--test-name', '--log-file' and '--trs-file' options are mandatory. 45 | ")) 46 | 47 | (define %options 48 | '((test-name (value #t)) 49 | (log-file (value #t)) 50 | (trs-file (value #t)) 51 | (color-tests (value #t)) 52 | (expect-failure (value #t)) ;XXX: not implemented yet 53 | (enable-hard-errors (value #t)) ;not implemented in SRFI-64 54 | (brief (value #t)) 55 | (help (single-char #\h) (value #f)) 56 | (version (single-char #\V) (value #f)))) 57 | 58 | (define (option->boolean options key) 59 | "Return #t if the value associated with KEY in OPTIONS is 'yes'." 60 | (and=> (option-ref options key #f) (cut string=? <> "yes"))) 61 | 62 | (define* (test-display field value #:optional (port (current-output-port)) 63 | #:key pretty?) 64 | "Display 'FIELD: VALUE\n' on PORT." 65 | (if pretty? 66 | (begin 67 | (format port "~A:~%" field) 68 | (pretty-print value port #:per-line-prefix "+ ")) 69 | (format port "~A: ~S~%" field value))) 70 | 71 | (define* (result->string symbol #:key colorize?) 72 | "Return SYMBOL as an upper case string. Use colors when COLORIZE is #t." 73 | (let ((result (string-upcase (symbol->string symbol)))) 74 | (if colorize? 75 | (string-append (case symbol 76 | ((pass) "") ;green 77 | ((xfail) "") ;light green 78 | ((skip) "") ;blue 79 | ((fail xpass) "") ;red 80 | ((error) "")) ;magenta 81 | result 82 | "") ;no color 83 | result))) 84 | 85 | (define* (test-runner-gnu test-name #:key color? brief? out-port trs-port) 86 | "Return an custom SRFI-64 test runner. TEST-NAME is a string specifying the 87 | file name of the current the test. COLOR? specifies whether to use colors, 88 | and BRIEF?, well, you know. OUT-PORT and TRS-PORT must be output ports. The 89 | current output port is supposed to be redirected to a '.log' file." 90 | 91 | (define (test-on-test-begin-gnu runner) 92 | ;; Procedure called at the start of an individual test case, before the 93 | ;; test expression (and expected value) are evaluated. 94 | (let ((result (cute assq-ref (test-result-alist runner) <>))) 95 | (format #t "test-name: ~A~%" (result 'test-name)) 96 | (format #t "location: ~A~%" 97 | (string-append (result 'source-file) ":" 98 | (number->string (result 'source-line)))) 99 | (test-display "source" (result 'source-form) #:pretty? #t))) 100 | 101 | (define (test-on-test-end-gnu runner) 102 | ;; Procedure called at the end of an individual test case, when the result 103 | ;; of the test is available. 104 | (let* ((results (test-result-alist runner)) 105 | (result? (cut assq <> results)) 106 | (result (cut assq-ref results <>))) 107 | (unless brief? 108 | ;; Display the result of each test case on the console. 109 | (format out-port "~A: ~A - ~A~%" 110 | (result->string (test-result-kind runner) #:colorize? color?) 111 | test-name (test-runner-test-name runner))) 112 | (when (result? 'expected-value) 113 | (test-display "expected-value" (result 'expected-value))) 114 | (when (result? 'expected-error) 115 | (test-display "expected-error" (result 'expected-error) #:pretty? #t)) 116 | (when (result? 'actual-value) 117 | (test-display "actual-value" (result 'actual-value))) 118 | (when (result? 'actual-error) 119 | (test-display "actual-error" (result 'actual-error) #:pretty? #t)) 120 | (format #t "result: ~a~%" (result->string (result 'result-kind))) 121 | (newline) 122 | (format trs-port ":test-result: ~A ~A~%" 123 | (result->string (test-result-kind runner)) 124 | (test-runner-test-name runner)))) 125 | 126 | (define (test-on-group-end-gnu runner) 127 | ;; Procedure called by a 'test-end', including at the end of a test-group. 128 | (let ((fail (or (positive? (test-runner-fail-count runner)) 129 | (positive? (test-runner-xpass-count runner)))) 130 | (skip (or (positive? (test-runner-skip-count runner)) 131 | (positive? (test-runner-xfail-count runner))))) 132 | ;; XXX: The global results need some refinements for XPASS. 133 | (format trs-port ":global-test-result: ~A~%" 134 | (if fail "FAIL" (if skip "SKIP" "PASS"))) 135 | (format trs-port ":recheck: ~A~%" 136 | (if fail "yes" "no")) 137 | (format trs-port ":copy-in-global-log: ~A~%" 138 | (if (or fail skip) "yes" "no")) 139 | (when brief? 140 | ;; Display the global test group result on the console. 141 | (format out-port "~A: ~A~%" 142 | (result->string (if fail 'fail (if skip 'skip 'pass)) 143 | #:colorize? color?) 144 | test-name)) 145 | #f)) 146 | 147 | (let ((runner (test-runner-null))) 148 | (test-runner-on-test-begin! runner test-on-test-begin-gnu) 149 | (test-runner-on-test-end! runner test-on-test-end-gnu) 150 | (test-runner-on-group-end! runner test-on-group-end-gnu) 151 | (test-runner-on-bad-end-name! runner test-on-bad-end-name-simple) 152 | runner)) 153 | 154 | ;;; 155 | ;;; Entry point. 156 | ;;; 157 | 158 | (define (main . args) 159 | (let* ((opts (getopt-long (command-line) %options)) 160 | (option (cut option-ref opts <> <>))) 161 | (cond 162 | ((option 'help #f) (show-help)) 163 | ((option 'version #f) (format #t "test-driver.scm ~A" script-version)) 164 | (else 165 | (let ((log (open-file (option 'log-file "") "w0")) 166 | (trs (open-file (option 'trs-file "") "wl")) 167 | (out (duplicate-port (current-output-port) "wl"))) 168 | (redirect-port log (current-output-port)) 169 | (redirect-port log (current-warning-port)) 170 | (redirect-port log (current-error-port)) 171 | (test-with-runner 172 | (test-runner-gnu (option 'test-name #f) 173 | #:color? (option->boolean opts 'color-tests) 174 | #:brief? (option->boolean opts 'brief) 175 | #:out-port out #:trs-port trs) 176 | (load-from-path (option 'test-name #f))) 177 | (close-port log) 178 | (close-port trs) 179 | (close-port out)))) 180 | (exit 0))) 181 | -------------------------------------------------------------------------------- /channels-lock.scm: -------------------------------------------------------------------------------- 1 | (list (channel 2 | (name 'guix) 3 | (url "https://codeberg.org/guix/guix-mirror") 4 | (branch "master") 5 | (commit 6 | "ede407920553f5d1ec58944db949ae13e94c6c56") 7 | (introduction 8 | (make-channel-introduction 9 | "9edb3f66fd807b096b48283debdcddccfea34bad" 10 | (openpgp-fingerprint 11 | "BBB0 2DDF 2CEA F6A8 0D1D E643 A2A0 6DF2 A33A 54FA")))) 12 | (channel 13 | (name 'guile-wayland) 14 | (url "https://github.com/guile-wayland/channel") 15 | (branch "master") 16 | (commit 17 | "777adcc7f61294a320f089a3d45b0d9ca41c1d89"))) 18 | 19 | ;; Local Variables: 20 | ;; mode: lisp-data 21 | ;; End: 22 | -------------------------------------------------------------------------------- /channels.scm: -------------------------------------------------------------------------------- 1 | (list (channel 2 | (inherit %default-guix-channel) 3 | (url "https://codeberg.org/guix/guix-mirror")) 4 | (channel 5 | (name 'guile-wayland) 6 | (introduction 7 | (make-channel-introduction 8 | "9e4433fe570d2b74caee0182a2929e4a35ba59fb" 9 | (openpgp-fingerprint 10 | "7EBE A494 60CE 5E2C 0875 7FDB 3B5A A993 E1A2 DFF0"))) 11 | (url "https://github.com/guile-wayland/channel"))) 12 | -------------------------------------------------------------------------------- /configure.ac: -------------------------------------------------------------------------------- 1 | AC_INIT([gwwm], [0.0.1], [873216071@qq.com]) 2 | AC_CONFIG_SRCDIR([gwwm]) 3 | AC_CONFIG_MACRO_DIR([m4]) 4 | AC_CONFIG_AUX_DIR([build-aux]) 5 | AM_INIT_AUTOMAKE([1.14 gnu tar-ustar silent-rules subdir-objects \ 6 | color-tests parallel-tests -Woverride -Wno-portability]) 7 | 8 | AM_SILENT_RULES([yes]) 9 | 10 | AC_CONFIG_FILES([Makefile po/Makefile.in]) 11 | AC_CONFIG_FILES([gwwm/configuration.scm]) 12 | AC_CONFIG_FILES([pre-inst-env], [chmod +x pre-inst-env]) 13 | 14 | AC_PROG_CC 15 | GUILE_PKG([3.0 2.2]) 16 | GUILE_PROGS 17 | GUILE_SITE_DIR 18 | 19 | dnl AC_CONFIG_FILES([pre-inst-env], [chmod +x pre-inst-env]) 20 | guilemoduledir="${datarootdir}/guile/site/$GUILE_EFFECTIVE_VERSION" 21 | guileobjectdir="${libdir}/guile/$GUILE_EFFECTIVE_VERSION/site-ccache" 22 | 23 | AC_USE_SYSTEM_EXTENSIONS 24 | AM_GNU_GETTEXT([external]) 25 | AM_GNU_GETTEXT_VERSION([0.21]) 26 | LT_INIT([dlopen]) 27 | dnl m4_pattern_allow([AC_LIB_LINKFLAGS_FROM_LIBS]) 28 | PKG_CHECK_MODULES([GUILE], [guile-3.0]) 29 | PKG_CHECK_MODULES([WAYLAND_SERVER], [wayland-server]) 30 | PKG_CHECK_MODULES([WLROOTS], [wlroots >= 0.17.0]) 31 | PKG_CHECK_MODULES([LIBINPUT],[libinput]) 32 | dnl PKG_CHECK_MODULES([WAYLAND_SCANNER], [wayland-scanner]) 33 | PKG_CHECK_MODULES([PIXMAN_1], [pixman-1]) 34 | PKG_CHECK_MODULES([XKBCOMMON],[xkbcommon]) 35 | PKG_CHECK_MODULES([XCB],[xcb]) 36 | #AC_CHECK_LIB() 37 | PKG_CHECK_VAR([WLROOTS_LIBDIR],[wlroots],[libdir]) 38 | PKG_CHECK_VAR([WAYLAND_LIBDIR],[wayland-server],[libdir]) 39 | PKG_CHECK_VAR([WAYLAND_SCANNER],[wayland-scanner],[wayland_scanner]) 40 | PKG_CHECK_VAR([WAYLAND_PROTOCOLS],[wayland-protocols],[pkgdatadir]) 41 | PKG_CHECK_VAR([LIBINPUT_LIBDIR],[libinput] ,[libdir]) 42 | PKG_CHECK_VAR([XCB_LIBDIR],[xcb] ,[libdir]) 43 | AC_SUBST([WLROOTS_LIBDIR]) 44 | AC_SUBST([WAYLAND_LIBDIR]) 45 | AC_SUBST([XCB_LIBDIR]) 46 | GUILE_MODULE_REQUIRED([bytestructures guile]) 47 | GUILE_MODULE_REQUIRED([srfi srfi-189]) 48 | GUILE_MODULE_REQUIRED([libinput]) 49 | GUILE_MODULE_REQUIRED([wayland server display]) 50 | GUILE_MODULE_REQUIRED([wlroots]) 51 | GUILE_MODULE_REQUIRED([util572 color]) 52 | 53 | AC_SUBST([guilemoduledir]) 54 | AC_SUBST([guileobjectdir]) 55 | AC_OUTPUT 56 | -------------------------------------------------------------------------------- /guix.scm: -------------------------------------------------------------------------------- 1 | (use-modules 2 | (guile-wayland packages guile-wayland) 3 | (guile-wayland packages guile-xyz) 4 | (guix utils) (guix packages) 5 | ((guix licenses) #:prefix license:) 6 | (gnu packages xorg) 7 | (guix download) 8 | (guix git-download) 9 | (gnu packages gettext) 10 | (guix gexp) 11 | (gnu packages gl) 12 | (gnu packages xdisorg) 13 | (guix build-system gnu) 14 | (gnu packages bash) 15 | (gnu packages) 16 | (gnu packages autotools) 17 | (gnu packages guile) 18 | (gnu packages gtk) 19 | (gnu packages guile-xyz) 20 | (gnu packages ibus) 21 | (gnu packages pkg-config) 22 | (gnu packages texinfo) 23 | (gnu packages pciutils) 24 | (gnu packages wm) 25 | (guix transformations) 26 | (gnu packages freedesktop)) 27 | 28 | (define %srcdir 29 | (dirname (current-filename))) 30 | 31 | (define-public gwwm 32 | (package 33 | (name "gwwm") 34 | (version "0.1") 35 | (source (local-file "." "gwwm-checkout" 36 | #:recursive? #t 37 | #:select? (git-predicate %srcdir))) 38 | (build-system gnu-build-system) 39 | (arguments 40 | (list #:make-flags 41 | #~(list "GUILE_AUTO_COMPILE=0") 42 | ;;; XXX: is a bug? why can't use gexp for #:modules 43 | #:modules `(((guix build guile-build-system) 44 | #:select (target-guile-effective-version)) 45 | ,@%gnu-build-system-modules) 46 | #:imported-modules `((guix build guile-build-system) 47 | ,@%gnu-build-system-modules) 48 | #:phases 49 | #~(modify-phases %standard-phases 50 | (add-after 'build 'load-extension 51 | (lambda* (#:key outputs #:allow-other-keys) 52 | (substitute* 53 | (find-files "." ".*\\.scm") 54 | (("\\(load-extension \"libgwwm\" *\"(.*)\"\\)" _ o) 55 | (string-append 56 | (object->string 57 | `(or (false-if-exception (load-extension "libgwwm" ,o)) 58 | (load-extension 59 | ,(string-append 60 | (assoc-ref outputs "out") 61 | "/lib/libgwwm.so") 62 | ,o)))))))) 63 | (add-after 'install 'wrap-executable 64 | (lambda* (#:key inputs outputs #:allow-other-keys) 65 | (let* ((out (assoc-ref outputs "out")) 66 | (deps (map (lambda (a) 67 | (assoc-ref inputs a )) 68 | '("guile-wayland" 69 | "guile-wlroots" 70 | "guile-bytestructures" 71 | "guile-bytestructure-class" 72 | "guile-util572" 73 | "guile-srfi-189" 74 | "guile-srfi-145" 75 | "guile-cairo" 76 | "guile-xkbcommon" 77 | "guile-libinput"))) 78 | (effective (target-guile-effective-version)) 79 | (mods (map (lambda (o) 80 | (string-append 81 | o "/share/guile/site/" effective)) 82 | (cons out deps))) 83 | (gos 84 | (map (lambda (o) 85 | (string-append 86 | o "/lib/guile/" effective "/site-ccache")) 87 | (cons out deps)))) 88 | (wrap-program (search-input-file outputs "bin/gwwm") 89 | #:sh (search-input-file inputs "bin/bash") 90 | `("GUILE_AUTO_COMPILE" ":" = ("0")) 91 | `("GUILE_LOAD_PATH" ":" prefix ,mods) 92 | `("GUILE_LOAD_COMPILED_PATH" ":" prefix ,gos)))))))) 93 | (native-inputs 94 | (list autoconf automake 95 | pkg-config 96 | libtool 97 | gettext-minimal 98 | guile-3.0-latest 99 | bash-minimal 100 | texinfo)) 101 | (inputs (list guile-3.0-latest 102 | guile-cairo 103 | guile-bytestructures 104 | guile-bytestructure-class 105 | guile-srfi-189 106 | guile-srfi-145 107 | guile-wlroots 108 | wlroots-0.17 109 | guile-util572 110 | guile-xkbcommon 111 | guile-libinput 112 | guile-wayland)) 113 | (synopsis "") 114 | (description "") 115 | (home-page "") 116 | (license license:gpl3+))) 117 | gwwm 118 | -------------------------------------------------------------------------------- /gwwm/buffer.scm: -------------------------------------------------------------------------------- 1 | (define-module (gwwm buffer) 2 | #:use-module (system foreign-object) 3 | #:use-module (cairo) 4 | #:use-module (oop goops) 5 | #:use-module (system foreign) 6 | #:use-module (wlroots types) 7 | #:use-module (wlroots types buffer) 8 | #:use-module (wayland signal) 9 | #:use-module (wayland list) 10 | #:use-module (wayland server listener) 11 | #:use-module (gwwm utils srfi-215) 12 | #:use-module (oop goops) 13 | 14 | #:export (cairo-buffer-create 15 | cairo-buffer-base 16 | cairo-buffer-cairo)) 17 | 18 | (use-modules (gwwm buffer) 19 | (oop goops describe) 20 | (gwwm client) 21 | (cairo) 22 | (wlroots types scene)) 23 | 24 | ;; (define (test) 25 | ;; (let* ((buf (cairo-buffer-create 30 40)) 26 | ;; (cr (cairo-buffer-cairo buf)) 27 | ;; (target (cairo-get-target cr))) 28 | ;; (cairo-set-source-rgba cr 1.0 0.4 1.0 1.0) 29 | ;; (cairo-set-fill-rule cr 'winding) 30 | ;; (cairo-rectangle cr 0 0 15 40) 31 | ;; (cairo-fill cr) 32 | ;; (cairo-set-source-rgba cr 0.4 1.0 1.0 1.0) 33 | ;; (cairo-rectangle cr 4 0 30 20) 34 | ;; (cairo-fill cr) 35 | ;; (cairo-surface-flush target) 36 | ;; (letrec* ((sc-b (wlr-scene-buffer-create (client-scene (car (client-list))) 37 | ;; (cairo-buffer-base buf))) 38 | ;; (node (.node sc-b)) 39 | ;; (listener (make-wl-listener 40 | ;; (lambda _ 41 | ;; (wlr-buffer-drop (cairo-buffer-base buf)) 42 | ;; (wl-listener-remove listener))))) 43 | ;; (wl-signal-add (get-event-signal node 'destroy) 44 | ;; listener)))) 45 | 46 | (eval-when (expand load eval) 47 | (load-extension "libgwwm" "scm_init_gwwm_buffer")) 48 | 49 | ;; (define DRM_FORMAT_ARGB8888 875713089) 50 | 51 | ;; (define (cairo-buffer-create width height) 52 | ;; (let* ((surface (cairo-image-surface-create 'argb32 width height)) 53 | ;; (cairo (cairo-create surface))) 54 | ;; (make 55 | ;; #:image-surface surface 56 | ;; #:cairo cairo 57 | ;; #:format DRM_FORMAT_ARGB8888))) 58 | 59 | (define-class () 60 | (%data #:init-keyword #:data)) 61 | -------------------------------------------------------------------------------- /gwwm/color.scm: -------------------------------------------------------------------------------- 1 | (define-module (gwwm color) 2 | #:use-module (gwwm utils) 3 | #:use-module (gwwm i18n) 4 | #:use-module (srfi srfi-26) 5 | #:use-module (ice-9 match) 6 | #:use-module (ice-9 format) 7 | #:use-module (oop goops) 8 | #:use-module (util572 color) 9 | #:use-module (system foreign) 10 | #:export (make-color color->pointer)) 11 | 12 | (define make-color make-rgba-color) 13 | (define-method (color->pointer (color )) 14 | (make-c-struct 15 | (list float float float float) 16 | (map (cut / <> 255) 17 | (color->list color)))) 18 | 19 | (define-method (color->pointer (color )) 20 | (color->pointer (make-color color))) 21 | (define-method (color->pointer (color )) 22 | (color->pointer (make-color color))) 23 | -------------------------------------------------------------------------------- /gwwm/commands.scm: -------------------------------------------------------------------------------- 1 | (define-module (gwwm commands) 2 | #:autoload (gwwm) (cursor-mode gwwm-xcursor-manager 3 | gwwm-session 4 | fullscreen-layer 5 | tile-layer 6 | grabc grabcx 7 | grabcy gwwm-cursor float-layer gwwm-display gwwm-scene) 8 | #:use-module (oop goops) 9 | #:use-module (wlroots backend session) 10 | #:use-module (wlroots backend) 11 | #:use-module (wlroots types scene) 12 | #:use-module (wlroots types cursor) 13 | #:use-module (wlroots types xcursor-manager) 14 | #:use-module (wayland server display) 15 | #:use-module (srfi srfi-26) 16 | #:use-module (srfi srfi-189) 17 | #:use-module (gwwm utils srfi-215) 18 | #:use-module (ice-9 control) 19 | #:use-module (gwwm config) 20 | #:use-module (util572 box) 21 | #:use-module (gwwm i18n) 22 | #:use-module (gwwm utils) 23 | #:use-module (gwwm monitor) 24 | #:use-module (gwwm layout) 25 | #:use-module (gwwm client) 26 | #:duplicates (merge-accessors merge-generics replace warn-override-core warn last) 27 | #:export (chvt 28 | killclient 29 | togglefullscreen 30 | togglefloating 31 | toggletag 32 | focusclient 33 | focustop 34 | gwwm-quit 35 | setlayout 36 | arrange 37 | focusstack 38 | tag 39 | moveresize 40 | incmaster 41 | view)) 42 | 43 | (define* (tag int #:optional (client (current-client))) 44 | (when client 45 | (set! (client-tags client) int) 46 | (focusclient (focustop (current-monitor)) #t) 47 | (arrange (current-monitor)))) 48 | 49 | (define (view i) 50 | (send-log DEBUG (G_ "view")) 51 | (let ((m(current-monitor))) 52 | (unless (= i (list-ref (slot-ref m 'tagset) (slot-ref m 'seltags))) 53 | (slot-set! m 'seltags (if (= 1 (slot-ref m 'seltags)) 0 1)) 54 | (list-set! (slot-ref m 'tagset) (slot-ref m 'seltags) i) 55 | (focusclient (focustop (current-monitor)) #t) 56 | (arrange (current-monitor))))) 57 | (define* (toggletag tag #:optional (client (current-client))) 58 | (when client 59 | (set! (client-tags client) tag) 60 | (focusclient (focustop (current-monitor)) #t) 61 | (arrange (current-monitor)))) 62 | 63 | 64 | (define* (list-scene-graph #:optional (tree (.tree (gwwm-scene)))) 65 | (let loop ((obj tree)) 66 | (cons obj 67 | (if (wlr-scene-tree? obj) 68 | (list (map (compose loop wlr-scene-object-from-node) 69 | (wlr-scene-tree-children obj))) 70 | (list))))) 71 | (export list-scene-graph) 72 | 73 | (define (arrange m) 74 | (for-each 75 | (lambda (c) 76 | (let ((cm (client-monitor c))) 77 | (when cm 78 | (client-scene-set-enabled c (visibleon c cm)) 79 | (cond ((client-fullscreen? c) 80 | (client-resize c (shallow-clone (monitor-area cm)) #f) 81 | (wlr-scene-node-reparent 82 | (.node (client-scene c)) 83 | (.node fullscreen-layer))) 84 | ((client-floating? c) 85 | (wlr-scene-node-reparent (.node (client-scene c)) (.node float-layer))) 86 | (else 87 | (wlr-scene-node-reparent (.node (client-scene c)) (.node tile-layer))))))) 88 | (client-list)) 89 | (and=> (list-ref (monitor-layouts m) (monitor-sellt m)) 90 | (lambda (lay) 91 | (and=> (layout-procedure lay) 92 | (cut <> m)))) 93 | ((@@ (gwwm) motionnotify) 0)) 94 | 95 | (define* (togglefullscreen #:optional (client (current-client))) 96 | (when client 97 | (client-do-set-fullscreen 98 | client (not (client-fullscreen? client))))) 99 | 100 | (define* (setlayout layout #:optional (m (current-monitor))) 101 | (unless (equal? (list-ref (monitor-layouts m) (monitor-sellt m)) layout) 102 | (set! (monitor-sellt m) (logxor (monitor-sellt m))) 103 | (list-set! (monitor-layouts m) (monitor-sellt m) layout) 104 | (arrange m))) 105 | 106 | 107 | (define* (togglefloating #:optional (client (current-client))) 108 | (when (and client (not (client-fullscreen? client))) 109 | (client-do-set-floating 110 | client 111 | (not (client-floating? client))))) 112 | 113 | (define* (incmaster num #:optional (m (current-monitor))) 114 | (set! (monitor-nmaster m ) 115 | (max (+ (monitor-nmaster m) num) 0)) 116 | (arrange m)) 117 | 118 | (define (focusclient client lift) 119 | ((@@ (gwwm) focusclient) client lift)) 120 | 121 | (define* (focusstack bool) 122 | (let ((c (current-client)) 123 | (m (current-monitor)) 124 | (c-l (client-list))) 125 | (unless (or (not c) 126 | (<= (length c-l) 1) 127 | (and (client-fullscreen? c) 128 | (lockfullscreen? ))) 129 | (and=> (let/ec return 130 | (for-each (lambda (o) 131 | (if (equal? c o) 132 | (return #f) 133 | (when (visibleon o m) 134 | (return o)))) 135 | ((if bool identity reverse) 136 | (cdr (member c (append c-l c-l)))))) 137 | (cut focusclient <> #t))))) 138 | 139 | (define (focustop monitor) 140 | (let/ec return 141 | (for-each (lambda (c) 142 | (when (visibleon c monitor) 143 | (return c))) 144 | (car (%fstack))) 145 | #f)) 146 | 147 | (define (moveresize n) 148 | (when (eq? (cursor-mode) 'normal) 149 | (grabc (maybe-ref (client-at (gwwm-cursor)) (const #f))) 150 | (let ((c (grabc)) 151 | (cursor (gwwm-cursor))) 152 | (when (and c 153 | (not (client-fullscreen? c))) 154 | (client-do-set-floating c #t) 155 | (cursor-mode n) 156 | (case n 157 | ((move) 158 | (grabcx (inexact->exact 159 | (round (- (.x cursor) 160 | (box-x (client-geom c)))))) 161 | (grabcy (inexact->exact 162 | (round (- (.y cursor) 163 | (box-y (client-geom c)))))) 164 | (wlr-cursor-set-xcursor 165 | cursor (gwwm-xcursor-manager) "fleur") 166 | (arrange (current-monitor))) 167 | ;; ((0) 'do-nothing) 168 | ((resize) 169 | (client-set-resizing! c #t) 170 | (let-slots (client-geom c) (x y width height ) 171 | (wlr-cursor-warp-closest cursor #f 172 | (+ x width) 173 | (+ y height))) 174 | (wlr-cursor-set-xcursor 175 | cursor 176 | (gwwm-xcursor-manager) 177 | "bottom_right_corner"))))))) 178 | 179 | (define* (killclient #:optional (client (current-client))) 180 | (and=> client client-send-close)) 181 | (define (chvt num) 182 | (wlr-session-change-vt 183 | (gwwm-session) 184 | num)) 185 | 186 | (define (gwwm-quit) 187 | (send-log INFO "try quit") 188 | (wl-display-terminate (gwwm-display))) 189 | -------------------------------------------------------------------------------- /gwwm/config.scm: -------------------------------------------------------------------------------- 1 | (define-module (gwwm config) 2 | #:use-module (xkbcommon xkbcommon) 3 | #:use-module (oop goops) 4 | #:use-module (oop goops describe) 5 | #:use-module (gwwm utils) 6 | #:use-module (gwwm i18n) 7 | #:use-module (gwwm color) 8 | #:use-module (srfi srfi-189) 9 | #:use-module (gwwm utils srfi-215) 10 | #:use-module (ice-9 optargs) 11 | #:export (gwwm 12 | load-init-file 13 | init-file 14 | make-xkb-rules 15 | get-option-value* 16 | get-option-value 17 | get-option-default-value* 18 | .name 19 | .mfact 20 | .nmaster 21 | .scale 22 | .reflect) 23 | #:export-syntax (define-config-option)) 24 | 25 | (define-once %config-options (make-object-property)) 26 | (define-syntax define-config-option 27 | (lambda (x) 28 | (syntax-case x () 29 | ((_ name default-value doc rest ...) 30 | (and (symbol? (syntax->datum #'name)) 31 | (string? (syntax->datum #'doc))) 32 | #`(begin 33 | (define-once name 34 | (if (%config-options 'name) 35 | (begin (send-log INFO (simple-format #f "option `~a' exists, use it." 36 | 'name) 37 | 'option 'name) 38 | (get-keyword #:parameter (%config-options 'name))) 39 | (let-keywords (list rest ...) 40 | #t ((conv identity)) 41 | (let ((o 42 | (make-parameter 43 | default-value 44 | (lambda (x) 45 | (let ((v (conv x))) 46 | (send-log 47 | DEBUG 48 | (simple-format 49 | #f "option `~a' value to `~a', converted value is `~a'" 50 | 'name x v) 51 | 'option 'name 'value x 'converted-value v) 52 | v))))) 53 | (set! (%config-options 'name) 54 | (list #:parameter o 55 | #:default-value default-value 56 | #:doc doc)) 57 | o)))) 58 | (export name)))))) 59 | 60 | (define-syntax-rule (get-option-value name) 61 | (get-option-value* 'name)) 62 | 63 | (define (get-option-value* name) 64 | (let-keywords (or (%config-options name) '()) 65 | #t 66 | ((parameter #f)) 67 | (if parameter 68 | (just (parameter)) 69 | (nothing)))) 70 | 71 | (define (get-option-default-value* name) 72 | (let ((o (%config-options name))) 73 | (if o 74 | (right (get-keyword #:default-value o)) 75 | (left (simple-format #f "option `~a' no exits." name))))) 76 | 77 | (define-class () 78 | (name #:init-value #f 79 | #:init-keyword #:name #:getter .name) 80 | (mfact #:init-value 0.55 81 | #:init-keyword #:mfact #:getter .mfact) 82 | (nmaster #:init-value 1 83 | #:init-keyword #:nmaster #:getter .nmaster) 84 | (scale #:init-value 1 85 | #:init-keyword #:scale #:getter .scale) 86 | (reflect #:init-value 'WL_OUTPUT_TRANSFORM_NORMAL 87 | #:init-keyword #:reflect #:getter .reflect)) 88 | 89 | (define-config-option monitor-rules 90 | (list) 91 | "") 92 | (define-config-option default-monitor-rules 93 | (make ) 94 | "") 95 | 96 | (define-config-option enable-xwayland? #f 97 | "if set to #t, enable xwayland.") 98 | 99 | (define-config-option borderpx 1 100 | "if set to #t, enable xwayland.") 101 | 102 | (define (init-file) 103 | "return init file." 104 | (string-append 105 | (get-xdg-config-home) 106 | "/gwwm/init.scm")) 107 | 108 | (define (load-init-file) 109 | (let ((init-file (init-file))) 110 | (if (file-exists? init-file) 111 | (save-module-excursion 112 | (lambda () 113 | (primitive-load init-file))) 114 | 115 | (send-log INFO (simple-format #f (G_ "initfile not found: ~a") init-file))))) 116 | 117 | (define* (make-xkb-rules 118 | #:optional 119 | (layout #f) 120 | (variant #f) 121 | (rules #f) 122 | #:key 123 | (model "") 124 | (options '())) 125 | (make 126 | #:model model 127 | #:layout layout 128 | #:variant variant 129 | #:rules rules 130 | #:options (string-join options ","))) 131 | 132 | (define-config-option xkb-rules (make-xkb-rules) 133 | "") 134 | 135 | (define-config-option repeat-rate 25 136 | "") 137 | 138 | (define-config-option bordercolor (make-color "#ffbbeeff") 139 | "") 140 | 141 | (define-config-option sloppyfocus? #t "") 142 | (define-config-option focuscolor (make-color 255 0 0 255) "") 143 | (define-config-option cursor-normal-image "right_ptr" "") 144 | (define-config-option lockfullscreen? #t "") 145 | 146 | (define-config-option quit-when-no-monitor? #t 147 | "if set to #t, when no monitor found, quit gwwm" 148 | #:conv ->bool) 149 | 150 | (define-syntax-rule (gwwm (init value) ...) 151 | (begin (init value) ...)) 152 | -------------------------------------------------------------------------------- /gwwm/configuration.scm.in: -------------------------------------------------------------------------------- 1 | (define-module (gwwm configuration) 2 | #:export (%version %bug-report-address %home-page-url)) 3 | (define %version "@PACKAGE_VERSION@") 4 | (define %bug-report-address 5 | "@PACKAGE_BUGREPORT@") 6 | 7 | (define %home-page-url 8 | "@PACKAGE_URL@") 9 | -------------------------------------------------------------------------------- /gwwm/hooks.scm: -------------------------------------------------------------------------------- 1 | (define-module (gwwm hooks) 2 | #:export (create-keyboard-hook 3 | create-client-hook 4 | create-monitor-hook 5 | create-pointer-hook 6 | axis-event-hook 7 | update-title-hook 8 | selection-hook 9 | modifiers-event-hook 10 | keypress-event-hook 11 | cursor-button-event-hook 12 | surface-commit-event-hook 13 | fullscreen-event-hook 14 | gwwm-cleanup-hook 15 | client-map-event-hook 16 | cursor-frame-event-hook 17 | create-popup-hook 18 | gwwm-after-init-hook 19 | client-fullscreen-hook 20 | client-destroy-hook 21 | keyboard-focus-change-hook 22 | motion-notify-hook)) 23 | 24 | (define-public create-monitor-hook (make-hook 1)) 25 | (define-public create-client-hook (make-hook 1)) 26 | (define-public create-pointer-hook (make-hook 1)) 27 | (define-public create-popup-hook (make-hook 1)) 28 | (define-public create-keyboard-hook (make-hook 1)) 29 | (define-public axis-event-hook (make-hook 1)) 30 | (define-public update-title-hook (make-hook 3)) 31 | (define-public selection-hook (make-hook 1)) 32 | (define-public fullscreen-event-hook (make-hook 1)) 33 | (define-public modifiers-event-hook (make-hook 1)) 34 | (define-public keypress-event-hook (make-hook 2)) 35 | (define-public cleanup-keyboard-hook (make-hook 1)) 36 | (define-public cursor-frame-event-hook (make-hook 1)) 37 | (define-public cursor-button-event-hook (make-hook 1)) 38 | (define-public surface-commit-event-hook (make-hook 1)) 39 | (define-public gwwm-cleanup-hook (make-hook 0)) 40 | (define-public gwwm-after-init-hook (make-hook 0)) 41 | (define-public client-map-event-hook (make-hook 2)) 42 | (define-public client-fullscreen-hook (make-hook 2)) 43 | (define-public client-destroy-hook (make-hook 1)) 44 | (define-public client-set-monitor-hook (make-hook 3)) 45 | (define-public keyboard-focus-change-hook (make-hook 3)) 46 | (define-public motion-notify-hook (make-hook 1)) 47 | -------------------------------------------------------------------------------- /gwwm/i18n.scm: -------------------------------------------------------------------------------- 1 | (define-module (gwwm i18n) 2 | #:use-module (srfi srfi-26) 3 | #:export (G_ 4 | N_ 5 | P_ 6 | %gettext-domain)) 7 | (define %gettext-domain 8 | ;; Text domain for strings used in the tools. 9 | "gwwm") 10 | 11 | (define G_ (cut gettext <> %gettext-domain)) 12 | (define N_ (cut ngettext <> <> <> %gettext-domain)) 13 | -------------------------------------------------------------------------------- /gwwm/keybind.scm: -------------------------------------------------------------------------------- 1 | (define-module (gwwm keybind) 2 | #:use-module (srfi srfi-1) 3 | #:use-module (srfi srfi-71) 4 | #:use-module (wlroots types keyboard) 5 | #:use-module (gwwm commands) 6 | #:use-module (oop goops ) 7 | #:use-module (gwwm keymap) 8 | #:use-module (ice-9 match)) 9 | 10 | (define SHIFT WLR_MODIFIER_SHIFT ) 11 | (define CAPS WLR_MODIFIER_CAPS ) 12 | (define CTRL WLR_MODIFIER_CTRL ) 13 | (define ALT WLR_MODIFIER_ALT ) 14 | (define MOD2 WLR_MODIFIER_MOD2 ) 15 | (define MOD3 WLR_MODIFIER_MOD3 ) 16 | (define LOGO WLR_MODIFIER_LOGO ) 17 | (define MOD5 WLR_MODIFIER_MOD5 ) 18 | 19 | (define-modify-key 'C CTRL) 20 | (define-modify-key 's LOGO) 21 | (define-modify-key 'S SHIFT) 22 | (define-modify-key 'M ALT) 23 | 24 | (define & logand) 25 | (define ^ logxor) 26 | (define ~ lognot) 27 | 28 | (define (have-mk mks mk) 29 | (not (= mks (& mks (~ mk))))) 30 | 31 | (define (ref-key k) 32 | (module-ref (resolve-interface '(gwwm keys)) 33 | (symbol-append 'key- k))) 34 | ;; (define-method (ref-key (k )) 35 | ;; (ref-key (string->symbol (number->string k)))) 36 | 37 | (define (clean-caps mks) 38 | (& mks (~ WLR_MODIFIER_CAPS))) 39 | 40 | (define* (keybinding mods sym #:optional (pressed #t)) 41 | (define handle (match-lambda 42 | ((k command release-command) 43 | (if (and (= (clean-caps mods) 44 | (clean-caps (apply logior (map parse-modify-key (.modify-keys k)))) ) 45 | (= sym (ref-key (.key k)))) 46 | (begin (if pressed 47 | (command) 48 | (release-command)) 49 | #t) 50 | #f)))) 51 | (any handle (.keys ((@@ (gwwm) global-keymap))))) 52 | -------------------------------------------------------------------------------- /gwwm/keyboard.scm: -------------------------------------------------------------------------------- 1 | (define-module (gwwm keyboard) 2 | #:use-module (oop goops) 3 | #:use-module (wlroots types input-device) 4 | #:use-module (ice-9 format) 5 | #:use-module (ice-9 q) 6 | #:use-module (gwwm listener) 7 | #:use-module (gwwm hooks) 8 | #:use-module (wlroots types keyboard) 9 | #:use-module (bytestructure-class) 10 | #:use-module (bytestructures guile) 11 | #:duplicates (merge-accessors merge-generics replace warn-override-core warn last) 12 | #:export (keyboard-list 13 | 14 | keyboard-rate 15 | keyboard-delay 16 | keyboard-set-repeat-info 17 | .device)) 18 | 19 | (define-class () 20 | (device #:init-keyword #:device #:accessor .device) 21 | (rate #:allocation #:virtual 22 | #:slot-ref (lambda (o) 23 | (let ((k (wlr-keyboard-from-input-device 24 | (slot-ref o 'device)))) 25 | (bytestructure-ref 26 | (get-bytestructure k) 27 | 'repeat-info 28 | 'rate))) 29 | #:slot-set! (lambda (o value) 30 | (let ((k (wlr-keyboard-from-input-device 31 | (slot-ref o 'device)))) 32 | (wlr-keyboard-set-repeat-info 33 | k value (slot-ref o 'delay)))) 34 | #:accessor keyboard-rate) 35 | (delay #:allocation #:virtual 36 | #:slot-ref (lambda (o) 37 | (let ((k (wlr-keyboard-from-input-device 38 | (slot-ref o 'device)))) 39 | (bytestructure-ref 40 | (get-bytestructure k) 41 | 'repeat-info 42 | 'delay))) 43 | #:slot-set! (lambda (o value) 44 | (let ((k (wlr-keyboard-from-input-device 45 | (slot-ref o 'device)))) 46 | (wlr-keyboard-set-repeat-info 47 | k (slot-ref o 'rate) value))) 48 | #:accessor keyboard-delay) 49 | #:metaclass ) 50 | 51 | (define-method (keyboard-set-repeat-info (k ) rate delay) 52 | (wlr-keyboard-set-repeat-info 53 | (wlr-keyboard-from-input-device (.device k)) rate delay)) 54 | 55 | (define-once %keyboards (make-q)) 56 | 57 | (define (add-keyboard keyboard) 58 | (q-push! %keyboards keyboard)) 59 | 60 | (define (remove-keyboard keyboard) 61 | (q-remove! %keyboards keyboard)) 62 | 63 | (define (keyboard-list) 64 | (car %keyboards)) 65 | 66 | (define-method (write (o ) port) 67 | (format port "#<~s ~S ~x>" 68 | (class-name (class-of o)) 69 | (.name (.device o)) 70 | (object-address o))) 71 | 72 | (define-method (initialize (o ) args) 73 | (let ((obj (next-method))) 74 | (add-keyboard obj) 75 | (add-listen (.device obj) 'destroy 76 | (lambda (listener data) 77 | (run-hook cleanup-keyboard-hook obj) 78 | (remove-keyboard obj))))) 79 | -------------------------------------------------------------------------------- /gwwm/keymap.scm: -------------------------------------------------------------------------------- 1 | (define-module (gwwm keymap) 2 | #:use-module (srfi srfi-1) 3 | #:use-module (srfi srfi-71) 4 | #:use-module (gwwm i18n) 5 | #:use-module (ice-9 match) 6 | #:use-module (oop goops) 7 | #:use-module (gwwm utils) 8 | #:export (make-keymap 9 | keymap-set 10 | .modify-keys 11 | .key 12 | .keys 13 | kbd* 14 | define-modify-key 15 | parse-modify-key 16 | 17 | ) 18 | #:export-syntax (kbd)) 19 | 20 | 21 | (define-class () 22 | (modify-keys #:init-value '() 23 | #:init-keyword #:m 24 | #:accessor .modify-keys) 25 | (key #:init-value 0 26 | #:init-keyword #:k 27 | #:accessor .key) 28 | #:metaclass ) 29 | 30 | (define-class () 31 | (keys #:init-value '() #:accessor .keys) 32 | #:metaclass ) 33 | 34 | (define (make-keymap) 35 | (make )) 36 | (define-method (equal? (key1 ) (key2 )) 37 | (and (equal? (.modify-keys key1) (.modify-keys key2)) 38 | (equal? (.key key1) (.key key2)))) 39 | 40 | (define-method (write (key ) port) 41 | (format port "#< m:~a k:~a>" 42 | (.modify-keys key ) 43 | (.key key))) 44 | 45 | (define-once %modify-keys 46 | (make-hash-table)) 47 | 48 | (define (define-modify-key symbol value) 49 | (hash-set! %modify-keys symbol value)) 50 | 51 | (define* (parse-modify-key m #:optional (error-when-no-found? #t)) 52 | (let ((o (hash-ref %modify-keys m))) 53 | (cond ((symbol? o) (parse-modify-key o)) 54 | ((number? o) o) 55 | (else (if error-when-no-found? 56 | (scm-error 'wrong-type-arg 'parse-modify-key "unknow mk!: ~S" 57 | (list o) 58 | (list o)) 59 | #f))))) 60 | 61 | (define-syntax-rule (kbd . rest) 62 | (apply kbd* 'rest)) 63 | 64 | (define kbd* 65 | (case-lambda 66 | ((kl) 67 | (let ((k mk (car+cdr (reverse kl)))) 68 | (list (make #:m mk #:k (->symbol k))))) 69 | ((kl . rest) 70 | (append (kbd* kl) (apply kbd* rest))))) 71 | 72 | (define-method (keymap-set (o ) (ks ) d . rest) 73 | (if (> (length ks) 1) 74 | (warn (G_ "for now, gwwm not support multi key define, ignore others."))) 75 | (apply keymap-set o (car ks) d rest)) 76 | 77 | (define-method (keymap-set (keymap ) 78 | (key ) 79 | (definition )) 80 | (keymap-set keymap key definition (const #t))) 81 | 82 | (define-method (keymap-set (keymap ) 83 | (key ) 84 | (definition ) 85 | (release-procedure )) 86 | (->bool (or (and=> (find-key-l key keymap) 87 | (lambda (l) 88 | (warn (format #f (G_ "replace keybmap definition ~S") l)) 89 | (set-cdr! l (list definition release-procedure)) 90 | #t)) 91 | (set! (.keys keymap) 92 | (cons (list key definition release-procedure) 93 | (.keys keymap)))))) 94 | 95 | (define-method (keymap-set (keymap ) 96 | (key ) 97 | (f )) 98 | (and=> (and (not f) 99 | (find-key-l key keymap)) 100 | (lambda (a) 101 | (->bool (set! (.keys keymap) 102 | (delete a (.keys keymap))))))) 103 | 104 | 105 | 106 | 107 | (define-method (find-key-l (key ) (keymap )) 108 | (find (lambda (o) (equal? (car o) key)) 109 | (.keys keymap))) 110 | 111 | (define (find-key-command key keymap) 112 | (and=> (find-key-l key keymap) 113 | second)) 114 | -------------------------------------------------------------------------------- /gwwm/keys.scm: -------------------------------------------------------------------------------- 1 | (define-module (gwwm keys)) 2 | (define-public key-Escape 9) 3 | (define-public key-1 10) 4 | (define-public key-2 11) 5 | (define-public key-3 12) 6 | (define-public key-4 13) 7 | (define-public key-5 14) 8 | (define-public key-6 15) 9 | (define-public key-7 16) 10 | (define-public key-8 17) 11 | (define-public key-9 18) 12 | (define-public key-0 19) 13 | (define-public key-minus 20) 14 | (define-public key-equal 21) 15 | (define-public key-BackSpace 22) 16 | (define-public key-Tab 23) 17 | (define-public key-q 24) 18 | (define-public key-w 25) 19 | (define-public key-e 26) 20 | (define-public key-r 27) 21 | (define-public key-t 28) 22 | (define-public key-y 29) 23 | (define-public key-u 30) 24 | (define-public key-i 31) 25 | (define-public key-o 32) 26 | (define-public key-p 33) 27 | (define-public key-bracketleft 34) 28 | (define-public key-bracketright 35) 29 | (define-public key-Return 36) 30 | (define-public key-Control-L 37) 31 | (define-public key-a 38) 32 | (define-public key-s 39) 33 | (define-public key-d 40) 34 | (define-public key-f 41) 35 | (define-public key-g 42) 36 | (define-public key-h 43) 37 | (define-public key-j 44) 38 | (define-public key-k 45) 39 | (define-public key-l 46) 40 | (define-public key-semicolon 47) 41 | (define-public key-apostrophe 48) 42 | (define-public key-grave 49) 43 | (define-public key-Shift-L 50) 44 | (define-public key-backslash 51) 45 | (define-public key-z 52) 46 | (define-public key-x 53) 47 | (define-public key-c 54) 48 | (define-public key-v 55) 49 | (define-public key-b 56) 50 | (define-public key-n 57) 51 | (define-public key-m 58) 52 | (define-public key-comma 59) 53 | (define-public key-period 60) 54 | (define-public key-slash 61) 55 | (define-public key-Shift-R 62) 56 | (define-public key-KP-Multiply 63) 57 | (define-public key-Alt-L 64) 58 | (define-public key-space 65) 59 | (define-public key-Caps-Lock 66) 60 | (define-public key-F1 67) 61 | (define-public key-F2 68) 62 | (define-public key-F3 69) 63 | (define-public key-F4 70) 64 | (define-public key-F5 71) 65 | (define-public key-F6 72) 66 | (define-public key-F7 73) 67 | (define-public key-F8 74) 68 | (define-public key-F9 75) 69 | (define-public key-F10 76) 70 | (define-public key-Num-Lock 77) 71 | (define-public key-Scroll-Lock 78) 72 | (define-public key-KP-Home 79) 73 | (define-public key-KP-7 key-KP-Home) 74 | (define-public key-KP-Up 80) 75 | (define-public key-KP-8 key-KP-Up) 76 | (define-public key-KP-Prior 81) 77 | (define-public key-KP-9 key-KP-Prior) 78 | (define-public key-KP-Subtract 82) 79 | (define-public key-KP-Left 83) 80 | (define-public key-KP-4 key-KP-Left) 81 | (define-public key-KP-Begin 84) 82 | (define-public key-KP-5 key-KP-Begin) 83 | (define-public key-KP-Right 85) 84 | (define-public key-KP-6 key-KP-Right) 85 | (define-public key-KP-Add 86) 86 | (define-public key-KP-End 87) 87 | (define-public key-KP-1 key-KP-End) 88 | (define-public key-KP-Down 88) 89 | (define-public key-KP-2 key-KP-Down) 90 | (define-public key-KP-Next 89) 91 | (define-public key-KP-3 key-KP-Next) 92 | (define-public key-KP-Insert 90) 93 | (define-public key-KP-0 key-KP-Insert) 94 | (define-public key-KP-Delete 91) 95 | (define-public key-KP-Period key-KP-Insert) 96 | (define-public key-ISO-Level3-Shift 92) 97 | (define-public key-less 94) 98 | (define-public key-F11 95) 99 | (define-public key-F12 96) 100 | (define-public key-Katakana 98) 101 | (define-public key-Hiragana 99) 102 | (define-public key-Henkan-Mode 100) 103 | (define-public key-Hiragana-Katakana 101) 104 | (define-public key-Muhenkan 102) 105 | (define-public key-KP-Enter 104) 106 | (define-public key-Control-R 105) 107 | (define-public key-KP-Divide 106) 108 | (define-public key-Print 107) 109 | (define-public key-Alt-R 108) 110 | (define-public key-Linefeed 109) 111 | (define-public key-Home 110) 112 | (define-public key-Up 111) 113 | (define-public key-Prior 112) 114 | (define-public key-Left 113) 115 | (define-public key-Right 114) 116 | (define-public key-End 115) 117 | (define-public key-Down 116) 118 | (define-public key-Next 117) 119 | (define-public key-Insert 118) 120 | (define-public key-Delete 119) 121 | (define-public key-XF86AudioMute 121) 122 | (define-public key-XF86AudioLowerVolume 122) 123 | (define-public key-XF86AudioRaiseVolume 123) 124 | (define-public key-XF86PowerOff 124) 125 | (define-public key-KP-Equal 125) 126 | (define-public key-plusminus 126) 127 | (define-public key-Pause 127) 128 | (define-public key-XF86LaunchA 128) 129 | (define-public key-KP-Decimal 129) 130 | (define-public key-Hangul 130) 131 | (define-public key-Hangul-Hanja 131) 132 | (define-public key-Super-L 133) 133 | (define-public key-Super-R 134) 134 | (define-public key-Menu 135) 135 | (define-public key-Cancel 136) 136 | (define-public key-Redo 137) 137 | (define-public key-SunProps 138) 138 | (define-public key-Undo 139) 139 | (define-public key-SunFront 140) 140 | (define-public key-XF86Copy 141) 141 | (define-public key-XF86Open 142) 142 | (define-public key-XF86Paste 143) 143 | (define-public key-Find 144) 144 | (define-public key-XF86Cut 145) 145 | (define-public key-Help 146) 146 | (define-public key-XF86MenuKB 147) 147 | (define-public key-XF86Calculator 148) 148 | (define-public key-XF86Sleep 150) 149 | (define-public key-XF86WakeUp 151) 150 | (define-public key-XF86Explorer 152) 151 | (define-public key-XF86Send 153) 152 | (define-public key-XF86Xfer 155) 153 | (define-public key-XF86Launch1 156) 154 | (define-public key-XF86Launch2 157) 155 | (define-public key-XF86WWW 158) 156 | (define-public key-XF86DOS 159) 157 | (define-public key-XF86ScreenSaver 160) 158 | (define-public key-XF86RotateWindows 161) 159 | (define-public key-XF86TaskPane 162) 160 | (define-public key-XF86Mail 163) 161 | (define-public key-XF86Favorites 164) 162 | (define-public key-XF86MyComputer 165) 163 | (define-public key-XF86Back 166) 164 | (define-public key-XF86Forward 167) 165 | (define-public key-XF86Eject1 169) 166 | (define-public key-XF86Eject2 170) 167 | (define-public key-XF86AudioNext 171) 168 | (define-public key-XF86AudioPlay 172) 169 | (define-public key-XF86AudioPrev 173) 170 | (define-public key-XF86AudioStop 174) 171 | (define-public key-XF86AudioRecord 175) 172 | (define-public key-XF86AudioRewind 176) 173 | (define-public key-XF86Phone 177) 174 | (define-public key-XF86Tools 179) 175 | (define-public key-XF86HomePage 180) 176 | (define-public key-XF86Reload 181) 177 | (define-public key-XF86Close 182) 178 | (define-public key-XF86ScrollUp 185) 179 | (define-public key-XF86ScrollDown 186) 180 | (define-public key-parenleft 187) 181 | (define-public key-parenright 188) 182 | (define-public key-XF86New 189) 183 | (define-public key-Redo2 190) 184 | (define-public key-XF86Tools2 191) 185 | (define-public key-XF86Launch5 192) 186 | (define-public key-XF86Launch6 193) 187 | (define-public key-XF86Launch7 194) 188 | (define-public key-XF86Launch8 195) 189 | (define-public key-XF86Launch9 196) 190 | (define-public key-XF86AudioMicMute 198) 191 | (define-public key-XF86TouchpadToggle 199) 192 | (define-public key-XF86TouchpadOn 200) 193 | (define-public key-XF86TouchpadOff 201) 194 | (define-public key-Mode-switch 203) 195 | (define-public key-XF86AudioPlay2 208) 196 | (define-public key-XF86AudioPause 209) 197 | (define-public key-XF86Launch3 210) 198 | (define-public key-XF86Launch4 211) 199 | (define-public key-XF86LaunchB 212) 200 | (define-public key-XF86Suspend 213) 201 | (define-public key-XF86Close2 214) 202 | (define-public key-XF86AudioPlay3 215) 203 | (define-public key-XF86AudioForward 216) 204 | (define-public key-Print2 218) 205 | (define-public key-XF86WebCam 220) 206 | (define-public key-XF86AudioPreset 221) 207 | (define-public key-XF86Mail2 223) 208 | (define-public key-XF86Messenger 224) 209 | (define-public key-XF86Search 225) 210 | (define-public key-XF86Go 226) 211 | (define-public key-XF86Finance 227) 212 | (define-public key-XF86Game 228) 213 | (define-public key-XF86Shop 229) 214 | (define-public key-Cancel2 231) 215 | (define-public key-XF86MonBrightnessDown 232) 216 | (define-public key-XF86MonBrightnessUp 233) 217 | (define-public key-XF86AudioMedia 234) 218 | (define-public key-XF86Display 235) 219 | (define-public key-XF86KbdLightOnOff 236) 220 | (define-public key-XF86KbdBrightnessDown 237) 221 | (define-public key-XF86KbdBrightnessUp 238) 222 | (define-public key-XF86Send2 239) 223 | (define-public key-XF86Reply 240) 224 | (define-public key-XF86MailForward 241) 225 | (define-public key-XF86Save 242) 226 | (define-public key-XF86Documents 243) 227 | (define-public key-XF86Battery 244) 228 | (define-public key-XF86Bluetooth 245) 229 | (define-public key-XF86WLAN 246) 230 | (define-public key-XF86MonBrightnessCycle 251) 231 | (define-public key-XF86WWAN 254) 232 | (define-public key-XF86RFKill 255) 233 | 234 | (define-public key-mouse-left 280) 235 | (define-public key-mouse-right 281) 236 | (define-public key-mouse-middle 282) 237 | (define-public key-mouse-side 283) 238 | (define-public key-mouse-extra 284) 239 | (define-public key-mouse-forward 285) 240 | (define-public key-mouse-back 286) 241 | (define-public key-mouse-task 287) 242 | -------------------------------------------------------------------------------- /gwwm/layout.scm: -------------------------------------------------------------------------------- 1 | (define-module (gwwm layout) 2 | #:use-module (oop goops) 3 | #:export ( 4 | layout-name 5 | layout-describe 6 | layout-procedure)) 7 | (define-class () 8 | (symbol #:init-value #f 9 | #:init-keyword #:symbol 10 | #:getter layout-symbol) 11 | (describe #:init-value "" 12 | #:init-keyword #:describe 13 | #:getter layout-describe) 14 | (procedure #:init-value #f 15 | #:init-keyword #:procedure 16 | #:accessor layout-procedure)) 17 | 18 | (define-method (equal? (layout1 ) (layout2 )) 19 | (and (equal? (layout-symbol layout1) (layout-symbol layout2)) 20 | (equal? (layout-describe layout1) (layout-describe layout2)) 21 | (equal? (layout-procedure layout1) (layout-procedure layout2)))) 22 | -------------------------------------------------------------------------------- /gwwm/layout/monocle.scm: -------------------------------------------------------------------------------- 1 | (define-module (gwwm layout monocle) 2 | ;; #:use-module (gwwm ) 3 | #:use-module (ice-9 control) 4 | #:use-module (oop goops) 5 | #:use-module (gwwm client) 6 | #:use-module (gwwm layout) 7 | #:use-module (gwwm monitor) 8 | #:use-module (gwwm commands) 9 | #:export (monocle-layout)) 10 | (define (monocle m) 11 | (let/ec return 12 | (for-each 13 | (lambda (c) 14 | (when (or (not (visibleon c m)) 15 | (client-floating? c) 16 | (client-fullscreen? c)) 17 | (return c)) 18 | (client-resize c (monitor-window-area m) 19 | #f)) 20 | (client-list))) 21 | (focusclient (focustop m) #t)) 22 | 23 | (define monocle-layout 24 | (make 25 | #:symbol "[m]" 26 | #:procedure monocle)) 27 | -------------------------------------------------------------------------------- /gwwm/layout/tile.scm: -------------------------------------------------------------------------------- 1 | (define-module (gwwm layout tile) 2 | #:use-module (oop goops) 3 | #:use-module (srfi srfi-1) 4 | #:use-module (srfi srfi-2) 5 | #:use-module (srfi srfi-71) 6 | #:use-module (ice-9 match) 7 | #:use-module (wlroots util box) 8 | #:use-module (util572 box) 9 | #:use-module (gwwm monitor) 10 | #:use-module (gwwm client) 11 | #:use-module (gwwm layout) 12 | #:export (tile-layout)) 13 | (define (tile m) 14 | (and-let* ((clients (filter (lambda (c) 15 | (and (visibleon c m) 16 | (not (client-floating? c)) 17 | (not (client-fullscreen? c)))) 18 | (client-list))) 19 | (l (length clients)) 20 | ((not (zero? l))) 21 | (mfact (monitor-mfact m)) 22 | (nmaster (monitor-nmaster m)) 23 | (window-box (monitor-window-area m)) 24 | (b (if (< nmaster l) 25 | (round (* mfact (box-width window-box))) 26 | (box-width window-box)))) 27 | (let ((nmaster-clients other-clients (split-at clients (min nmaster l)))) 28 | (match (split-box window-box b 'y) 29 | ((nmaster-box other-box) 30 | (let ((p (lambda (cls box) 31 | (unless (zero? (length cls)) 32 | (for-each (lambda (c box) 33 | (client-resize c box)) 34 | cls 35 | (split-box/n 36 | box 37 | (round 38 | (/ (box-height window-box) 39 | (length cls))) 'x)))))) 40 | (p nmaster-clients nmaster-box) 41 | (p other-clients (if (zero? nmaster) 42 | window-box 43 | other-box)))))))) 44 | 45 | (define tile-layout 46 | (make 47 | #:symbol "[t]" 48 | #:procedure tile)) 49 | -------------------------------------------------------------------------------- /gwwm/listener.scm: -------------------------------------------------------------------------------- 1 | (define-module (gwwm listener) 2 | #:use-module (system foreign) 3 | #:use-module (wlroots types) 4 | #:use-module (wayland signal) 5 | #:use-module (wayland list) 6 | #:use-module (wayland server listener) 7 | #:use-module (gwwm utils srfi-215) 8 | #:use-module (oop goops) 9 | #:export (add-listen)) 10 | 11 | (define* (add-listen obj symbol proc 12 | #:key 13 | (destroy-when obj) 14 | (remove-when-destroy? #t)) 15 | (let ((listener (make-wl-listener proc))) 16 | (send-log DEBUG "listener added" 'object obj 'event symbol) 17 | (wl-signal-add (get-event-signal obj symbol) listener) 18 | (when remove-when-destroy? 19 | (letrec ((remove-listener 20 | (make-wl-listener 21 | (lambda _ 22 | (send-log DEBUG "listener removed" 'object obj 'event symbol) 23 | (wl-listener-remove listener) 24 | (wl-listener-remove remove-listener))))) 25 | (wl-signal-add 26 | (get-event-signal destroy-when 'destroy) remove-listener))))) 27 | -------------------------------------------------------------------------------- /gwwm/monitor.scm: -------------------------------------------------------------------------------- 1 | (define-module (gwwm monitor) 2 | #:autoload (gwwm) (gwwm-output-layout) 3 | #:use-module (srfi srfi-1) 4 | #:use-module (ice-9 format) 5 | #:use-module (ice-9 q) 6 | #:use-module (oop goops) 7 | #:use-module (util572 box) 8 | #:use-module (wayland list) 9 | #:use-module (wlroots types) 10 | #:use-module (wlroots types output) 11 | #:use-module (wlroots types output-layout) 12 | #:use-module (bytestructure-class) 13 | #:export (current-monitor 14 | monitor-name 15 | monitor-description 16 | monitor-enabled? 17 | monitor-scale 18 | monitor-height 19 | monitor-list 20 | monitor-width 21 | monitor-refresh 22 | monitor-physical-width 23 | monitor-physical-height 24 | monitor-at 25 | monitor-output 26 | monitor-layouts 27 | monitor-window-area 28 | monitor-scene-output 29 | monitor-area 30 | monitor-sellt 31 | monitor-nmaster 32 | monitor-mfact 33 | dirtomon 34 | 35 | %monitors 36 | wlr-output->monitor)) 37 | 38 | (define-once wlr-output->monitor (make-object-property)) 39 | (define-once %monitors 40 | (make-parameter 41 | (make-q) 42 | (lambda (o) 43 | (if (q? o) o 44 | (error "not a q! ~A" o))))) 45 | (define (monitor-list) 46 | "return all monitors." 47 | (car (%monitors))) 48 | (define-once %current-monitor #f) 49 | (define (get-current-monitor) 50 | %current-monitor) 51 | (define (set-current-monitor m) 52 | (set! %current-monitor m)) 53 | (define current-monitor (make-procedure-with-setter 54 | get-current-monitor 55 | set-current-monitor)) 56 | (define-inlinable (%monitor-output m) 57 | (slot-ref m '%output)) 58 | (define-class () 59 | (%output #:accessor monitor-output 60 | #:setter set-.wlr-output! 61 | #:init-keyword #:wlr-output) 62 | (name #:allocation #:virtual 63 | #:slot-ref (lambda (m) (.name (%monitor-output m))) 64 | #:slot-set! (lambda _ #f) 65 | #:getter monitor-name) 66 | (area #:accessor monitor-area 67 | #:setter set-.area!) 68 | (window-area #:accessor monitor-window-area 69 | #:setter set-.window-area!) 70 | (description #:allocation #:virtual 71 | #:slot-ref (lambda (m) (.description (%monitor-output m))) 72 | #:slot-set! (lambda _ #f) 73 | #:getter monitor-description) 74 | (enabled? #:allocation #:virtual 75 | #:slot-ref (lambda (m) (.enabled (%monitor-output m))) 76 | #:slot-set! (lambda (m b) 77 | (wlr-output-enable 78 | (%monitor-output m) b)) 79 | #:accessor monitor-enabled?) 80 | (width #:allocation #:virtual 81 | #:slot-ref (lambda (m) (.width (%monitor-output m))) 82 | #:slot-set! (lambda _ #f) 83 | #:getter monitor-width) 84 | (height #:allocation #:virtual 85 | #:slot-ref (lambda (m) (.height (%monitor-output m))) 86 | #:slot-set! (lambda _ #f) 87 | #:getter monitor-height) 88 | (scale #:allocation #:virtual 89 | #:slot-ref (lambda (m) (.scale (%monitor-output m))) 90 | #:slot-set! (lambda (m o) 91 | (wlr-output-set-scale (%monitor-output m) o)) 92 | #:accessor monitor-scale) 93 | (refresh #:allocation #:virtual 94 | #:slot-ref (lambda (m) (.refresh (%monitor-output m))) 95 | #:slot-set! (lambda _ #f) 96 | #:getter monitor-refresh) 97 | (physical-width #:allocation #:virtual 98 | #:slot-ref (lambda (m) 99 | (.phys-width (%monitor-output m))) 100 | #:slot-set! (lambda _ #f) 101 | #:getter monitor-physical-width) 102 | (physical-height #:allocation #:virtual 103 | #:slot-ref (lambda (m) 104 | (.phys-height (%monitor-output m))) 105 | #:slot-set! (lambda _ #f) 106 | #:getter monitor-physical-height) 107 | (scene-output #:accessor monitor-scene-output #:init-value #f ) 108 | 109 | (layouts #:init-value (list #f #f) 110 | #:accessor monitor-layouts 111 | #:setter set-.monitor-layouts 112 | #:init-keyword #:layouts) 113 | (sellt #:init-value 0 114 | #:accessor monitor-sellt 115 | #:setter set-.monitor-sellt!) 116 | (layers #:init-thunk 117 | (lambda () 118 | (list (make-q) 119 | (make-q) 120 | (make-q) 121 | (make-q)))) 122 | (nmaster #:init-value 1 #:accessor monitor-nmaster) 123 | (mfact #:init-value 1/2 #:accessor monitor-mfact) 124 | (seltags #:init-value 0) 125 | (tagset #:init-thunk (lambda () (list 1 1))) 126 | #:metaclass ) 127 | 128 | (define-method (write (o ) port) 129 | (format port "#<~a ~a ~x (~a . ~a) scale: ~a>" 130 | (class-name (class-of o)) 131 | (monitor-name o) 132 | (object-address o) 133 | (monitor-width o) 134 | (monitor-height o) 135 | (monitor-scale o))) 136 | 137 | (define (monitor-at x y) 138 | (and=> (wlr-output-layout-output-at 139 | (gwwm-output-layout) x y) 140 | wlr-output->monitor)) 141 | 142 | (define (dirtomon dir) 143 | (define p wlr-output->monitor) 144 | (let* ((m (current-monitor)) 145 | (area (monitor-area m))) 146 | (or 147 | (and=> (wlr-output-layout-adjacent-output 148 | (gwwm-output-layout) 149 | (bs:enum->integer %wlr-direction-enum dir) 150 | (monitor-output m) 151 | (box-x area) 152 | (box-y area)) 153 | p) 154 | (and=> (wlr-output-layout-farthest-output 155 | (gwwm-output-layout) 156 | (logxor (bs:enum->integer %wlr-direction-enum 157 | dir) 12 ;; dir ^ (WLR_DIRECTION_LEFT|WLR_DIRECTION_RIGHT) 158 | ) 159 | (monitor-output m) 160 | (box-x area) 161 | (box-y area)) 162 | p) 163 | m))) 164 | -------------------------------------------------------------------------------- /gwwm/packages/fullscreen-bg.scm: -------------------------------------------------------------------------------- 1 | (define-module (gwwm packages fullscreen-bg) 2 | #:use-module (oop goops) 3 | #:use-module (srfi srfi-2) 4 | #:use-module (wlroots types scene) 5 | #:use-module (util572 color) 6 | #:use-module (util572 box) 7 | #:use-module (gwwm client) 8 | #:use-module (gwwm hooks) 9 | #:use-module (gwwm config) 10 | #:export (fullscreen-bg-mode 11 | fullscreen-bg-color)) 12 | 13 | (define-once fullscreen-bg-color 14 | (make-parameter 15 | (make-rgba-color 0 0 0 255) 16 | (lambda (new) 17 | (if (is-a? new ) 18 | new 19 | (error "not a object!" new))))) 20 | 21 | (define-once %bgs 22 | (make-weak-key-hash-table 23 | ;; random number 24 | 40)) 25 | 26 | (define-method (client-bg c) 27 | (hashv-ref %bgs c)) 28 | (define-method ((setter client-bg) c bg) 29 | (hashv-set! %bgs c bg)) 30 | (define (remove-bg c) 31 | (hashv-remove! %bgs c)) 32 | (define (for-each-bg f) 33 | (hash-for-each f %bgs)) 34 | 35 | (define (add-bg/maybe c) 36 | (unless (client-bg c) 37 | (let ((bg (wlr-scene-rect-create 38 | (client-scene c) 39 | (box-width (client-geom c)) 40 | (box-height (client-geom c)) 41 | (fullscreen-bg-color)))) 42 | (wlr-scene-node-set-enabled (.node bg) #f) 43 | (wlr-scene-node-lower-to-bottom (.node bg)) 44 | (set! (client-bg c) bg)))) 45 | 46 | (define (set-bg c fullscreen?) 47 | (add-bg/maybe c) 48 | (let ((bg (client-bg c))) 49 | (if fullscreen? 50 | (begin 51 | (wlr-scene-rect-set-size 52 | bg 53 | (box-width (client-geom c)) 54 | (box-height (client-geom c))) 55 | (wlr-scene-rect-set-color 56 | bg (fullscreen-bg-color)) 57 | (wlr-scene-node-set-enabled (.node bg) #t)) 58 | (wlr-scene-node-set-enabled (.node bg) #f)))) 59 | 60 | (define* (fullscreen-bg-mode #:optional (enable? #t) ) 61 | (if enable? 62 | (begin (add-hook! client-fullscreen-hook set-bg) 63 | (and-let* ((c (current-client)) 64 | (fullscreen? (client-fullscreen? c ))) 65 | (set-bg c fullscreen?))) 66 | (begin (for-each-bg 67 | (lambda (c bg) 68 | (when (client-alive? c) 69 | (wlr-scene-node-destroy (.node bg))))) 70 | (remove-hook! client-fullscreen-hook set-bg))) 71 | *unspecified*) 72 | -------------------------------------------------------------------------------- /gwwm/pointer.scm: -------------------------------------------------------------------------------- 1 | (define-module (gwwm pointer) 2 | #:use-module (oop goops) 3 | #:use-module (gwwm listener) 4 | #:use-module (wlroots types input-device) 5 | #:use-module (wlroots types pointer) 6 | #:use-module (wlroots backend libinput) 7 | #:use-module (bytestructure-class) 8 | #:use-module (libinput) 9 | #:use-module (srfi srfi-2) 10 | #:use-module (srfi srfi-189) 11 | #:use-module (ice-9 format) 12 | #:use-module (ice-9 q) 13 | #:duplicates (merge-accessors merge-generics replace warn-override-core warn last) 14 | #:export (pointer-list 15 | 16 | pointer-disable-while-typing? 17 | pointer-left-handed? 18 | pointer-middle-emulation? 19 | pointer-natural-scroll? 20 | .device)) 21 | 22 | (define (has-natural-scroll? device) 23 | (truth->either 24 | (libinput-device-config-scroll-has-natural-scroll device) 25 | "device is not has natural-scroll")) 26 | 27 | (define (left-handed-is-available? device) 28 | (truth->either 29 | (libinput-device-config-left-handed-is-available device) 30 | "left-handed is unavailable")) 31 | (define (dwt-is-available? libinput-device) 32 | (truth->either 33 | (libinput-device-config-dwt-is-available libinput-device) 34 | "disable-while-typing? is unavailable")) 35 | 36 | (define (middle-emulation-is-available? device) 37 | (truth->either 38 | (libinput-device-config-middle-emulation-is-available device) 39 | "middle emulation is unavailable")) 40 | 41 | (define (s-ref-f has? get handle) 42 | (lambda (o) 43 | (either-let* ((device (get-libinput-device o)) 44 | ((has? device))) 45 | (handle (get device))))) 46 | 47 | (define (s-set-f has? set handle) 48 | (lambda (o v) 49 | (either-let* ((v (or (and (either? v) v) (right v))) 50 | (device (get-libinput-device o)) 51 | ((has? device))) 52 | (set 53 | device 54 | (handle v device))))) 55 | 56 | (define-inlinable (not-zero? v) 57 | (not (zero? v))) 58 | (define-class () 59 | (device #:init-keyword #:device #:accessor .device) 60 | (disable-while-typing? 61 | #:accessor pointer-disable-while-typing? 62 | #:allocation #:virtual 63 | #:slot-ref 64 | (s-ref-f dwt-is-available? 65 | libinput-device-config-dwt-get-enabled 66 | (compose not-zero? 67 | %libinput-config-dwt-state-enum->number)) 68 | #:slot-set! 69 | (s-set-f dwt-is-available? 70 | libinput-device-config-dwt-set-enabled 71 | (lambda (v d)(case v 72 | ((#t) 'LIBINPUT_CONFIG_DWT_ENABLED) 73 | ((#f) 'LIBINPUT_CONFIG_DWT_DISABLED) 74 | ((reset) (libinput-device-config-dwt-get-default-enabled d)))))) 75 | (left-handed? 76 | #:accessor pointer-left-handed? 77 | #:allocation #:virtual 78 | #:slot-ref 79 | (s-ref-f left-handed-is-available? 80 | libinput-device-config-left-handed-get 81 | not-zero?) 82 | #:slot-set! 83 | (s-set-f left-handed-is-available? 84 | libinput-device-config-left-handed-set 85 | (lambda (v device) 86 | (case v 87 | ((#t) 1) 88 | ((#f) 0) 89 | ((reset) (libinput-device-config-left-handed-get-default device)))))) 90 | (middle-emulation? 91 | #:accessor pointer-middle-emulation? 92 | #:allocation #:virtual 93 | #:slot-ref 94 | (s-ref-f 95 | middle-emulation-is-available? 96 | libinput-device-config-middle-emulation-get-enabled 97 | (compose not-zero? 98 | %libinput-config-middle-emulation-state-enum->number)) 99 | #:slot-set! 100 | (s-set-f 101 | middle-emulation-is-available? 102 | libinput-device-config-middle-emulation-set-enabled 103 | (lambda (v d) 104 | (case v 105 | ((#t) 1) 106 | ((#f) 0) 107 | ((reset) libinput-device-config-middle-emulation-get-default-enabled d)) ))) 108 | (natural-scroll? 109 | #:accessor pointer-natural-scroll? 110 | #:allocation #:virtual 111 | #:slot-ref 112 | (s-ref-f has-natural-scroll? 113 | libinput-device-config-scroll-get-natural-scroll-enabled 114 | not-zero?) 115 | #:slot-set! 116 | (s-set-f has-natural-scroll? 117 | libinput-device-config-scroll-set-natural-scroll-enabled 118 | (lambda (v d) 119 | (case v 120 | ((#t) 1) 121 | ((#f) 0) 122 | ((reset) 123 | (libinput-device-config-scroll-get-default-natural-scroll-enabled 124 | d)))))) 125 | #:metaclass ) 126 | 127 | (define-method (write (o ) port) 128 | (format port "#<~s ~S ~x>" 129 | (class-name (class-of o)) 130 | (.name (.device o)) 131 | (object-address o))) 132 | 133 | (define-method (get-libinput-device (p )) 134 | (let ((device (slot-ref p 'device))) 135 | (if (wlr-input-device-is-libinput device) 136 | (right (wlr-libinput-get-device-handle device)) 137 | (left "device is not libinput")))) 138 | 139 | (define-once %pointers (make-q)) 140 | (define (pointer-list) 141 | (car %pointers)) 142 | (define (add-pointer o) 143 | (q-push! %pointers o)) 144 | (define (remove-pointer o) 145 | (q-remove! %pointers o)) 146 | (define-method (initialize (o ) args) 147 | (let ((obj (next-method))) 148 | (add-pointer obj) 149 | (add-listen (.device obj) 'destroy 150 | (lambda (listener data) 151 | (remove-pointer obj))))) 152 | -------------------------------------------------------------------------------- /gwwm/popup.scm: -------------------------------------------------------------------------------- 1 | (define-module (gwwm popup) 2 | #:use-module (oop goops) 3 | #:use-module (gwwm listener) 4 | #:use-module (ice-9 q) 5 | #:export ( 6 | popup-list 7 | wlr-xdg-popup->popup 8 | .popup)) 9 | (define-class () 10 | (popup #:accessor .popup #:init-keyword #:popup) 11 | #:metaclass ) 12 | 13 | (define-once %popup (make-q)) 14 | (define (popup-list) 15 | (car %popup)) 16 | (define (add-popup o) 17 | (q-push! %popup o)) 18 | (define (remove-popup o) 19 | (q-remove! %popup o)) 20 | 21 | (define-once wlr-xdg-popup->popup (make-object-property)) 22 | (define-method (initialize (o ) args) 23 | (let* ((obj (next-method)) 24 | (device (.device obj))) 25 | (add-popup obj) 26 | (set! (wlr-xdg-popup->popup 27 | (wlr-popup-from-input-device device)) obj) 28 | (add-listen device 'destroy 29 | (lambda (listener data) 30 | (set! (wlr-xdg-popup->popup device) #f) 31 | (remove-popup obj))))) 32 | -------------------------------------------------------------------------------- /gwwm/touch.scm: -------------------------------------------------------------------------------- 1 | (define-module (gwwm touch) 2 | #:use-module (oop goops) 3 | #:use-module (gwwm listener) 4 | #:use-module (wlroots types touch) 5 | #:use-module (ice-9 q) 6 | #:export ( 7 | 8 | touch-list 9 | wlr-touch->touch 10 | .device)) 11 | (define-class () 12 | (device #:accessor .device #:init-keyword #:device) 13 | #:metaclass ) 14 | 15 | (define-class () 16 | (touch-id #:init-keyword #:touch-id) 17 | (x #:init-keyword #:x) 18 | (y #:init-keyword #:y) 19 | #:metaclass ) 20 | 21 | (define-once %touch (make-q)) 22 | (define (touch-list) 23 | (car %touch)) 24 | (define (add-touch o) 25 | (q-push! %touch o)) 26 | (define (remove-touch o) 27 | (q-remove! %touch o)) 28 | 29 | (define-once wlr-touch->touch (make-object-property)) 30 | (define-method (initialize (o ) args) 31 | (let* ((obj (next-method)) 32 | (device (.device obj))) 33 | (add-touch obj) 34 | (set! (wlr-touch->touch 35 | (wlr-touch-from-input-device device)) obj) 36 | (add-listen device 'destroy 37 | (lambda (listener data) 38 | (set! (wlr-touch->touch device) #f) 39 | (remove-touch obj))))) 40 | -------------------------------------------------------------------------------- /gwwm/user.scm: -------------------------------------------------------------------------------- 1 | (define-module (gwwm user) 2 | #:use-module (wlroots) 3 | #:use-module (gwwm client) 4 | #:use-module (gwwm commands) 5 | #:use-module (gwwm config) 6 | #:use-module (gwwm i18n) 7 | #:use-module (gwwm keyboard) 8 | #:use-module (gwwm keymap) 9 | #:use-module (gwwm monitor) 10 | #:use-module (gwwm pointer) 11 | #:use-module (gwwm popup) 12 | #:use-module (gwwm touch) 13 | #:use-module (gwwm utils ref) 14 | #:use-module (gwwm utils srfi-215) 15 | #:use-module (gwwm utils) 16 | #:use-module (gwwm) 17 | #:use-module (oop goops describe) 18 | #:use-module (oop goops) 19 | #:use-module (oop goops) 20 | #:use-module (srfi srfi-1) 21 | #:use-module (srfi srfi-189) 22 | #:use-module (srfi srfi-19) 23 | #:use-module (srfi srfi-2) 24 | #:use-module (srfi srfi-26) 25 | #:use-module (srfi srfi-71) 26 | #:use-module (util572 box) 27 | #:duplicates (merge-accessors merge-generics replace warn-override-core warn last) ) 28 | -------------------------------------------------------------------------------- /gwwm/utils.scm: -------------------------------------------------------------------------------- 1 | (define-module (gwwm utils) 2 | #:use-module (oop goops) 3 | #:use-module (oop goops describe) 4 | #:use-module ((rnrs base) #:select (assert)) 5 | #:use-module (ice-9 format) 6 | #:use-module (gwwm i18n) 7 | #:export (->symbol 8 | ->string 9 | getenv* 10 | get-xdg-config-home 11 | string-split-length) 12 | #:export-syntax (save-environment-excursion 13 | with-env 14 | let-slots 15 | modify-instance 16 | modify-instance*)) 17 | 18 | (define (get-slot-getter obj sym) 19 | (let* ((class (class-of obj)) 20 | (def (class-slot-definition class sym)) 21 | (get (or (and=> (slot-definition-getter def) 22 | (lambda (gett) 23 | (lambda ()(gett obj)))) 24 | (and=> (slot-definition-accessor def) 25 | (lambda (gett) 26 | (lambda () (gett obj)))) 27 | (lambda () (slot-ref obj sym))))) 28 | get)) 29 | 30 | (define (get-slot-set obj sym) 31 | (let* ((class (class-of obj)) 32 | (def (class-slot-definition class sym)) 33 | (set (or (and=> (slot-definition-setter def) 34 | (lambda (set-f) 35 | (lambda (var) 36 | (set-f obj var)))) 37 | (and=> (slot-definition-accessor def) 38 | (lambda (set-f) 39 | (lambda (var) 40 | (set! (set-f obj) var)))) 41 | (lambda (val) (slot-set! obj sym val))))) 42 | set)) 43 | 44 | (define-syntax let-slots 45 | (lambda (x) 46 | (syntax-case x () 47 | ((_ obj (slot ...) body body* ...) 48 | (let* ((slots (map (lambda (o) 49 | (syntax-case o () 50 | ((slot-name changed-name) 51 | #'(slot-name changed-name)) 52 | (slot-name 53 | #'(slot-name slot-name)))) 54 | #'(slot ...)))) 55 | (syntax-case slots () 56 | (((name changed) ...) 57 | (with-syntax (((%get ...) (generate-temporaries #'(name ...))) 58 | ((%set ...) (generate-temporaries #'(name ...)))) 59 | #`(let ((%obj obj)) 60 | (assert (instance? %obj)) 61 | (let ((%get (get-slot-getter %obj 'name)) ... 62 | (%set (get-slot-set %obj 'name)) ...) 63 | (letrec-syntax 64 | ((changed 65 | (identifier-syntax 66 | (var (%get)) 67 | ((set! var val) 68 | (%set val)))) ...) 69 | body body* ...))))))))))) 70 | 71 | (define-syntax modify-instance 72 | (lambda (x) 73 | (syntax-case x () 74 | ((_ obj ((slot-name changed-name) sexp ...) ...) 75 | #'(let ((obj* obj)) 76 | (let-slots obj* ((slot-name changed-name) ...) 77 | (set! slot-name 78 | (begin sexp ...)) ...))) 79 | ((_ obj (slot-name sexp ...) ...) 80 | #'(let ((obj* obj)) 81 | (let-slots obj* (slot-name ...) 82 | (set! slot-name 83 | (begin sexp ...)) ...)))))) 84 | 85 | (define-syntax modify-instance* 86 | (lambda (x) 87 | (syntax-case x () 88 | ((_ obj ((slot-name changed-name) sexp ...) ...) 89 | #'(let ((obj* obj)) 90 | (let-slots obj* ((slot-name changed-name) ...) 91 | (let ((out (begin sexp ...))) 92 | (set! changed-name out)) ...))) 93 | ((_ obj (slot-name sexp ...) ...) 94 | #'(let ((obj* obj)) 95 | (let-slots obj* (slot-name ...) 96 | (let ((out (begin sexp ...))) 97 | (set! slot-name out)) ...)))))) 98 | 99 | ;;; copy from guix. 100 | (define-syntax-rule (save-environment-excursion body ...) 101 | "Save the current environment variables, run BODY..., and restore them." 102 | (let ((env (environ))) 103 | (dynamic-wind 104 | (const #t) 105 | (lambda () 106 | body ...) 107 | (lambda () 108 | (environ env))))) 109 | 110 | (define-syntax with-env 111 | (lambda (x) 112 | " 113 | (getenv \"HOME\") => \"/root\" 114 | (with-env ((\"HOME\" \"/tmp\")) 115 | (getenv \"HOME\")) => \"/tmp\" 116 | " 117 | (syntax-case x () 118 | ((_ ((env value) ...) body ...) 119 | #'(save-environment-excursion 120 | (setenv env value) 121 | ... 122 | body ...))))) 123 | 124 | 125 | 126 | (define* (getenv* nam #:optional fallback) 127 | "like getenv, but if NAM environment variable not found return FALLBACK." 128 | (or (getenv nam) fallback)) 129 | 130 | (define (get-xdg-config-home) 131 | "return XDG_CONFIG_HOME." 132 | (getenv* "XDG_CONFIG_HOME" 133 | (string-append (getenv "HOME") "/.config"))) 134 | 135 | (define-method (describe (m )) 136 | (format #t (G_ "~S is a hashtable, value is:~%~:{\t~s => ~s\n~}.~%") 137 | m (hash-map->list 138 | list m)) 139 | *unspecified*) 140 | 141 | (define-method (->symbol (o )) 142 | o) 143 | (define-method (->symbol (o )) 144 | (->symbol (number->string o))) 145 | 146 | (define-method (->symbol (o )) 147 | (string->symbol o)) 148 | 149 | (define-method (->symbol (o )) 150 | (keyword->symbol o)) 151 | 152 | (define-method (->string (o )) 153 | o) 154 | 155 | (define-method (->string (o )) 156 | (->string (keyword->symbol o))) 157 | 158 | (define-method (->string (o )) 159 | (symbol->string o)) 160 | 161 | (define-method (->string (o )) 162 | (number->string o)) 163 | -------------------------------------------------------------------------------- /gwwm/utils/ref.scm: -------------------------------------------------------------------------------- 1 | ;;; Copyright (C) 2022 Zheng Junjie <873216071@qq.com> 2 | ;;; simple srfi-123, use goops, not sure bug. 3 | 4 | (define-module (gwwm utils ref) 5 | #:use-module (oop goops) 6 | #:use-module (srfi srfi-17) 7 | #:use-module (rnrs bytevectors) 8 | #:use-module (srfi srfi-9) 9 | #:use-module (srfi srfi-111) 10 | #:export (ref ref* ~ )) 11 | 12 | (define-accessor ref) 13 | (define-accessor ref*) 14 | 15 | (define ~ ref*) 16 | (define set (setter ref)) 17 | (define set* (setter ref*)) 18 | 19 | (define-method (ref o field) 20 | (cond ((record? o) 21 | ((record-accessor 22 | (record-type-descriptor o) 23 | field) 24 | o)))) 25 | 26 | (define-method (set o field value) 27 | (cond ((record? o) 28 | ((record-modifier 29 | (record-type-descriptor o) 30 | field) 31 | o value)))) 32 | 33 | (define-method (ref (o ) field) 34 | (vector-ref o field)) 35 | 36 | (define-method (set (o ) field obj) 37 | (vector-set! o field obj)) 38 | 39 | (define-method (ref (o ) field) 40 | (s16vector-ref o field)) 41 | 42 | (define-method (ref (o ) field) 43 | (bytevector-u8-ref o field)) 44 | 45 | (define-method (set (o ) field value) 46 | (bytevector-u8-set! o field value)) 47 | 48 | (define-method (ref* o field) 49 | (ref o field)) 50 | (define-method (ref* o field . field+) 51 | (apply ref* (ref o field) field+)) 52 | 53 | (define-method (set* . fields) 54 | (let ((reversed-fields (reverse fields))) 55 | (set! (ref (apply ref* (reverse (cdr (cdr reversed-fields)))) 56 | (car (cdr reversed-fields)) ) 57 | (car reversed-fields)))) 58 | (define-method (ref (o ) field) 59 | (string-ref o field)) 60 | 61 | (define-method (set (o ) field value) 62 | (string-set! o field value)) 63 | 64 | (define-method (ref (o ) field default) 65 | (hash-ref o field default)) 66 | 67 | (define-method (set (o ) field value) 68 | (hash-set! o field value)) 69 | 70 | (define-method (ref (o ) field) 71 | (list-ref o field)) 72 | 73 | (define-method (set (o ) field value) 74 | (list-set! o field value)) 75 | 76 | (define-method (ref (o ) (field )) 77 | (case field 78 | ((car) (car o)) 79 | ((cdr) (cdr o)))) 80 | 81 | (define-method (set (o ) (field ) value) 82 | (case field 83 | ((car) (set-car! o value)) 84 | ((cdr) (set-cdr! o value)))) 85 | 86 | (define-method (ref (o ) field) 87 | (list-ref o field)) 88 | 89 | (define-method (set (o ) field value) 90 | (list-set! o field value)) 91 | 92 | (define-method (ref (o ) (field )) 93 | (let* ((c (class-of o)) 94 | (def (class-slot-definition c field)) 95 | (getter (or (slot-definition-getter def) 96 | (slot-definition-accessor def) 97 | (lambda (o) (slot-ref o field))))) 98 | (getter o))) 99 | 100 | (define-method (ref (o ) field) 101 | (char-set-ref o field)) 102 | 103 | (define-method (set (o ) (field ) item) 104 | (let* ((c (class-of o)) 105 | (def (class-slot-definition c field)) 106 | (s (or (slot-definition-setter def) 107 | (and=> (slot-definition-accessor def) 108 | (lambda (sett) 109 | (lambda (o item) 110 | ((setter sett) o item)))) 111 | (lambda (o sl) (slot-set! o field sl))))) 112 | (s o item))) 113 | -------------------------------------------------------------------------------- /gwwm/utils/srfi-215.scm: -------------------------------------------------------------------------------- 1 | ;; -*-scheme-*- 2 | ;; © 2020 Göran Weinholt 3 | ;; © 2022 Zheng Junjie 4 | 5 | ;; Permission is hereby granted, free of charge, to any person 6 | ;; obtaining a copy of this software and associated documentation files 7 | ;; (the "Software"), to deal in the Software without restriction, 8 | ;; including without limitation the rights to use, copy, modify, merge, 9 | ;; publish, distribute, sublicense, and/or sell copies of the Software, 10 | ;; and to permit persons to whom the Software is furnished to do so, 11 | ;; subject to the following conditions: 12 | ;; 13 | ;; The above copyright notice and this permission notice (including the 14 | ;; next paragraph) shall be included in all copies or substantial 15 | ;; portions of the Software. 16 | ;; 17 | ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 18 | ;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 19 | ;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 20 | ;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS 21 | ;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN 22 | ;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN 23 | ;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 24 | ;; SOFTWARE. 25 | 26 | (define-module (gwwm utils srfi-215) 27 | #:use-module (ice-9 q) 28 | #:use-module (srfi srfi-35) 29 | #:use-module (scheme base) 30 | #:use-module (oop goops) 31 | #:use-module (scheme write) 32 | #:export 33 | (send-log 34 | current-log-fields 35 | current-log-callback 36 | EMERGENCY ALERT CRITICAL ERROR WARNING NOTICE INFO DEBUG)) 37 | ;; use (ice-9 q) replace srfi-215 example's queue. 38 | 39 | ;; These severities are from RFC 5424 ("The Syslog Protocol"). 40 | (define EMERGENCY 0) ; system is unusable 41 | (define ALERT 1) ; action must be taken immediately 42 | (define CRITICAL 2) ; critical conditions 43 | (define ERROR 3) ; error conditions 44 | (define WARNING 4) ; warning conditions 45 | (define NOTICE 5) ; normal but significant condition 46 | (define INFO 6) ; informational messages 47 | (define DEBUG 7) ; debug-level messages 48 | 49 | (define (field-list->alist plist) 50 | (let f ((fields plist)) 51 | (cond ((null? fields) 52 | '()) 53 | ((or (not (pair? fields)) (not (pair? (cdr fields)))) 54 | (error "short field list" plist)) 55 | (else 56 | (let ((k (car fields)) (v (cadr fields))) 57 | (if (not v) 58 | (f (cddr fields)) 59 | (let ((k^ (cond ((symbol? k) k) 60 | (else 61 | (error "invalid key" k plist)))) 62 | (v^ (cond ((string? v) v) 63 | ((and (integer? v) (exact? v)) v) 64 | ((bytevector? v) v) 65 | ((instance? v) v) 66 | ((condition? v) v) 67 | ((error-object? v) v) ;R7RS 68 | (else 69 | (let ((p (open-output-string))) 70 | (write v p) 71 | (get-output-string p)))))) 72 | (cons (cons k^ v^) 73 | (f (cddr fields)))))))))) 74 | 75 | (define current-log-fields 76 | (make-parameter '() 77 | (lambda (plist) 78 | (field-list->alist plist) 79 | plist))) 80 | 81 | (define current-log-callback 82 | (let ((num-pending-logs 0) 83 | (pending-logs (make-q))) 84 | (make-parameter (lambda (log-entry) 85 | (enq! pending-logs log-entry) 86 | (if (eqv? num-pending-logs 100) 87 | (q-pop! pending-logs) 88 | (set! num-pending-logs (+ num-pending-logs 1)))) 89 | (lambda (hook) 90 | (unless (procedure? hook) 91 | (error "current-log-hook: expected a procedure" hook)) 92 | (let ((q pending-logs)) 93 | (set! num-pending-logs 0) 94 | (set! pending-logs (make-q)) 95 | (let lp () 96 | (unless (q-empty? q) 97 | (hook (q-pop! q)) 98 | (lp)))) 99 | hook)))) 100 | 101 | ;; Send a log entry with the given severity and message. This 102 | ;; procedure also takes a list of extra keys and values. 103 | (define (send-log severity message . plist) 104 | (unless (and (exact? severity) (integer? severity) (<= 0 severity 7)) 105 | (error "send-log: expected a severity from 0 to 7" 106 | severity message plist)) 107 | (unless (string? message) 108 | (error "send-log: expected message to be a string" 109 | severity message plist)) 110 | (let* ((fields (append plist (current-log-fields))) 111 | (alist (field-list->alist fields))) 112 | ((current-log-callback) `((SEVERITY . ,severity) 113 | (MESSAGE . ,message) 114 | ,@alist)))) 115 | -------------------------------------------------------------------------------- /gwwm/web.scm: -------------------------------------------------------------------------------- 1 | (define-module (gwwm web) 2 | #:use-module ((web server) #:prefix web:) 3 | #:autoload (web response) (build-response) 4 | #:use-module (sxml simple) 5 | #:use-module (gwwm) 6 | #:use-module (gwwm client) 7 | 8 | #:use-module (wlroots types output-layout) 9 | #:use-module (util572 box) 10 | #:use-module (wlroots util box) 11 | #:use-module (gwwm i18n) 12 | #:use-module (gwwm keyboard) 13 | #:use-module (gwwm touch) 14 | #:use-module (gwwm pointer) 15 | #:use-module (gwwm keymap) 16 | #:use-module (gwwm layout tile) 17 | #:use-module (gwwm layout) 18 | #:use-module (gwwm listener) 19 | #:use-module (gwwm monitor) 20 | #:use-module (wlroots types cursor) 21 | #:use-module (oop goops) 22 | #:duplicates (merge-accessors merge-generics replace warn-override-core warn last) 23 | #:export (run-debug-web-server)) 24 | 25 | (define (templatize title body) 26 | `(html (head (title ,title)) 27 | (body ,@body))) 28 | (define* (respond #:optional body #:key 29 | (status 200) 30 | (title "Hello hello!") 31 | (doctype "\n") 32 | (content-type-params '((charset . "utf-8"))) 33 | (content-type 'text/html) 34 | (extra-headers '()) 35 | (sxml (and body (templatize title body)))) 36 | (values (build-response 37 | #:code status 38 | #:headers `((content-type 39 | . (,content-type ,@content-type-params)) 40 | ,@extra-headers)) 41 | (lambda (port) 42 | (if sxml 43 | (begin 44 | (if doctype (display doctype port)) 45 | (sxml->xml sxml port)))))) 46 | 47 | (define (web-build-monitor) 48 | (map (lambda (x) 49 | `(ol 50 | (li ,(monitor-name x)) 51 | (li ,(object->string 52 | (monitor-window-area x))))) 53 | (monitor-list))) 54 | (define (web-build-client) 55 | (map (lambda (x) 56 | `(ol 57 | (li ,(string-append 58 | "appid: " 59 | (object->string 60 | (client-appid x)))) 61 | (li ,(string-append 62 | "title: " 63 | (object->string 64 | (client-title x)))) 65 | (li ,(string-append 66 | "geom: " 67 | (object->string 68 | (client-geom x)))) 69 | (li ,(string-append 70 | "monitor: " 71 | (object->string 72 | (client-monitor x)))))) 73 | (client-list))) 74 | 75 | (define (web-build-cursor) 76 | (define cursor (gwwm-cursor)) 77 | `(p ,(string-append "cursor: " 78 | (object->string 79 | (cons (.x cursor) (.y cursor)))))) 80 | 81 | (define (web-build-variables) 82 | `((p ,(string-append "current-monitor: " 83 | (object->string (current-monitor)))) 84 | (p ,(string-append "current-client: " 85 | (object->string (current-client)))) 86 | (p ,(string-append "entire-layout-box: " 87 | (object->string (entire-layout-box)))) 88 | (p ,(string-append "layout-box: " 89 | (object->string 90 | (wlr-output-layout-get-box 91 | (gwwm-output-layout))))))) 92 | 93 | (define (draw-monitor m) 94 | (define cb (monitor-window-area m)) 95 | (define x (box-x cb)) 96 | (define y (box-y cb)) 97 | `((g (rect (@ (x ,x) 98 | (y ,y) 99 | (width ,(box-width cb)) 100 | (height ,(box-height cb)) 101 | (fill "#cc0000") 102 | (fill-opacity 0.1) 103 | (stroke "black") 104 | (stroke-width 0.5))) 105 | (text (@ (x ,x) 106 | (y ,(+ 12 y)) 107 | (fill "red")) 108 | 109 | ,(monitor-name m))))) 110 | (define (draw-client c) 111 | (define cb (client-geom c)) 112 | (define x (box-x cb)) 113 | (define y (box-y cb)) 114 | `((g 115 | (rect (@ (x ,x) 116 | (y ,y) 117 | (width ,(box-width cb)) 118 | (height ,(box-height cb)) 119 | (stroke "blue") 120 | (fill-opacity 0.9) 121 | (fill "#cccccc") 122 | (stroke-width 123 | ,(client-border-width c)))) 124 | (text (@ (x ,(+ 36 x)) 125 | (y ,(+ 24 y)) 126 | (fill "black")) 127 | ,(string-append 128 | "title: " 129 | (object->string (client-title c)) 130 | " " 131 | "appid:" 132 | (object->string (client-appid c))))))) 133 | (define (draw-cursor) 134 | (define cursor (gwwm-cursor)) 135 | (define x (.x cursor)) 136 | (define y (.y cursor)) 137 | `((g 138 | (rect (@ (x ,x) 139 | (y ,y) 140 | (width 24) 141 | (height 24) 142 | (fill-opacity 0.5) 143 | (fill "blue"))) 144 | (text (@ (x ,x) 145 | (y ,(+ 12 y)) 146 | (fill "black")) 147 | "cursor")))) 148 | (define (web-handler request request-body) 149 | (respond 150 | (list (web-build-variables) 151 | (web-build-monitor) 152 | (web-build-client) 153 | (web-build-cursor) 154 | (let* ((box (wlr-output-layout-get-box (gwwm-output-layout)))) 155 | `(svg (@ (width ,(box-width box)) 156 | (height ,(box-height box)) 157 | (xmlns "http://www.w3.org/2000/svg")) 158 | ,@(map draw-monitor (monitor-list)) 159 | ,@(map draw-client (client-list)) 160 | ,@(draw-cursor)))) 161 | #:title "gwwm web")) 162 | (define (run-debug-web-server) 163 | (web:run-server (lambda (request request-body) 164 | (web-handler request request-body)))) 165 | -------------------------------------------------------------------------------- /gwwm/x-client.scm: -------------------------------------------------------------------------------- 1 | (define-module (gwwm x-client) 2 | #:autoload (gwwm) (fullscreen-layer float-layer tile-layer overlay-layer top-layer bottom-layer background-layer gwwm-seat arrangelayers) 3 | #:autoload (gwwm commands) (arrange) 4 | #:autoload (gwwm config) (gwwm-borderpx g-config) 5 | #:duplicates (merge-generics replace warn-override-core warn last) 6 | #:use-module (srfi srfi-1) 7 | #:use-module (srfi srfi-2) 8 | #:use-module (srfi srfi-26) 9 | #:use-module (srfi srfi-71) 10 | #:use-module (srfi srfi-189) 11 | #:use-module (gwwm utils srfi-215) 12 | #:use-module (wlroots types scene) 13 | #:use-module (wlroots types compositor) 14 | #:use-module (wlroots types subcompositor) 15 | #:use-module (wlroots types layer-shell) 16 | #:use-module (wlroots time) 17 | #:use-module (ice-9 q) 18 | #:use-module (ice-9 control) 19 | #:use-module (ice-9 format) 20 | #:use-module (gwwm utils) 21 | #:use-module (util572 color) 22 | #:use-module (wlroots xwayland) 23 | #:use-module (gwwm monitor) 24 | #:use-module (gwwm hooks) 25 | #:use-module (wayland server listener) 26 | #:use-module (wayland list) 27 | #:use-module (wlroots types seat) 28 | #:use-module (wlroots util box) 29 | #:use-module (util572 box) 30 | #:use-module (wlroots types xdg-shell) 31 | #:use-module (wlroots types cursor) 32 | #:use-module (gwwm listener) 33 | #:use-module (gwwm i18n) 34 | #:use-module (gwwm client) 35 | #:use-module (oop goops) 36 | #:use-module (oop goops describe) 37 | 38 | #:export ( 39 | client-is-x11?)) 40 | (define-class ()) 41 | (define-method (client-mapped? (c )) 42 | (wlr-xwayland-surface-mapped? (client-super-surface c))) 43 | (define-method (client-wants-fullscreen? (c )) 44 | (.fullscreen (client-super-surface c))) 45 | (define-method (client-do-set-fullscreen (c ) fullscreen?) 46 | (next-method) 47 | (wlr-xwayland-surface-set-fullscreen (client-super-surface c) 48 | fullscreen?)) 49 | (define-method (client-get-parent (c )) 50 | (and=> (.parent (client-super-surface c)) 51 | (lambda (x) (client-from-wlr-surface (.surface x))))) 52 | (define-method (client-get-appid (c )) 53 | (or (and=> (client-super-surface c) 54 | wlr-xwayland-surface-class) 55 | "*unknow*")) 56 | (define-method (client-get-title (c )) 57 | (wlr-xwayland-surface-title 58 | (client-super-surface c))) 59 | (define-method (client-send-close (c )) 60 | (wlr-xwayland-surface-close (client-super-surface c))) 61 | (define (client-is-x11? client) 62 | (is-a? client )) 63 | (define-method (client-is-unmanaged? (client )) 64 | (wlr-xwayland-surface-override-redirect (client-super-surface client))) 65 | (define-method (client-set-resizing! (c ) resizing?) 66 | *unspecified*) 67 | (define-method (client-get-size-hints (c )) 68 | (%get-size-hints-helper (.size-hints (client-super-surface c)))) 69 | (define-method (client-restack-surface (c )) 70 | (wlr-xwayland-surface-restack (client-super-surface c) #f 0)) 71 | (define-method (client-set-tiled (c ) edges) 72 | *unspecified*) 73 | (define-method (client-get-geometry (c )) 74 | (let ((s (client-super-surface c))) 75 | (make-wlr-box (wlr-xwayland-surface-x s) 76 | (wlr-xwayland-surface-y s) 77 | (wlr-xwayland-surface-width s) 78 | (wlr-xwayland-surface-height s)))) 79 | (define-method (client-set-size! (c ) width height) 80 | (wlr-xwayland-surface-configure (client-super-surface c) 81 | (box-x (client-geom c)) 82 | (box-y (client-geom c)) 83 | width height) 84 | 0) 85 | 86 | (define-method (client-request-fullscreen-notify (c )) 87 | (lambda (listener data) 88 | (send-log DEBUG "client request fullscreen" 'client c) 89 | (let ((fullscreen? (client-wants-fullscreen? c))) 90 | (if (client-monitor c) 91 | (client-do-set-fullscreen c fullscreen?) 92 | (set! (client-fullscreen? c) fullscreen?)) 93 | (run-hook fullscreen-event-hook c)))) 94 | -------------------------------------------------------------------------------- /manifest.scm: -------------------------------------------------------------------------------- 1 | 2 | (use-modules (guix profiles)) 3 | (use-modules 4 | (srfi srfi-1) 5 | (guix packages) 6 | (guix profiles) 7 | (guix transformations)) 8 | 9 | (concatenate-manifests (list (specifications->manifest 10 | (list "bear" "gdb" "guile:debug")) 11 | 12 | (package->development-manifest 13 | (primitive-load (string-append (dirname (current-filename))"/guix.scm") )))) 14 | -------------------------------------------------------------------------------- /po/LINGUAS: -------------------------------------------------------------------------------- 1 | zh_CN -------------------------------------------------------------------------------- /po/Makefile.in.in: -------------------------------------------------------------------------------- 1 | # Makefile for PO directory in any package using GNU gettext. 2 | # Copyright (C) 1995-2000 Ulrich Drepper 3 | # Copyright (C) 2000-2020 Free Software Foundation, Inc. 4 | # 5 | # Copying and distribution of this file, with or without modification, 6 | # are permitted in any medium without royalty provided the copyright 7 | # notice and this notice are preserved. This file is offered as-is, 8 | # without any warranty. 9 | # 10 | # Origin: gettext-0.21 11 | GETTEXT_MACRO_VERSION = 0.20 12 | 13 | PACKAGE = @PACKAGE@ 14 | VERSION = @VERSION@ 15 | PACKAGE_BUGREPORT = @PACKAGE_BUGREPORT@ 16 | 17 | SED = @SED@ 18 | SHELL = /bin/sh 19 | @SET_MAKE@ 20 | 21 | srcdir = @srcdir@ 22 | top_srcdir = @top_srcdir@ 23 | VPATH = @srcdir@ 24 | 25 | prefix = @prefix@ 26 | exec_prefix = @exec_prefix@ 27 | datarootdir = @datarootdir@ 28 | datadir = @datadir@ 29 | localedir = @localedir@ 30 | gettextsrcdir = $(datadir)/gettext/po 31 | 32 | INSTALL = @INSTALL@ 33 | INSTALL_DATA = @INSTALL_DATA@ 34 | 35 | # We use $(mkdir_p). 36 | # In automake <= 1.9.x, $(mkdir_p) is defined either as "mkdir -p --" or as 37 | # "$(mkinstalldirs)" or as "$(install_sh) -d". For these automake versions, 38 | # @install_sh@ does not start with $(SHELL), so we add it. 39 | # In automake >= 1.10, @mkdir_p@ is derived from ${MKDIR_P}, which is defined 40 | # either as "/path/to/mkdir -p" or ".../install-sh -c -d". For these automake 41 | # versions, $(mkinstalldirs) and $(install_sh) are unused. 42 | mkinstalldirs = $(SHELL) @install_sh@ -d 43 | install_sh = $(SHELL) @install_sh@ 44 | MKDIR_P = @MKDIR_P@ 45 | mkdir_p = @mkdir_p@ 46 | 47 | # When building gettext-tools, we prefer to use the built programs 48 | # rather than installed programs. However, we can't do that when we 49 | # are cross compiling. 50 | CROSS_COMPILING = @CROSS_COMPILING@ 51 | 52 | GMSGFMT_ = @GMSGFMT@ 53 | GMSGFMT_no = @GMSGFMT@ 54 | GMSGFMT_yes = @GMSGFMT_015@ 55 | GMSGFMT = $(GMSGFMT_$(USE_MSGCTXT)) 56 | XGETTEXT_ = @XGETTEXT@ 57 | XGETTEXT_no = @XGETTEXT@ 58 | XGETTEXT_yes = @XGETTEXT_015@ 59 | XGETTEXT = $(XGETTEXT_$(USE_MSGCTXT)) 60 | MSGMERGE = @MSGMERGE@ 61 | MSGMERGE_UPDATE = @MSGMERGE@ --update 62 | MSGMERGE_FOR_MSGFMT_OPTION = @MSGMERGE_FOR_MSGFMT_OPTION@ 63 | MSGINIT = msginit 64 | MSGCONV = msgconv 65 | MSGFILTER = msgfilter 66 | 67 | POFILES = @POFILES@ 68 | GMOFILES = @GMOFILES@ 69 | UPDATEPOFILES = @UPDATEPOFILES@ 70 | DUMMYPOFILES = @DUMMYPOFILES@ 71 | DISTFILES.common = Makefile.in.in remove-potcdate.sin \ 72 | $(DISTFILES.common.extra1) $(DISTFILES.common.extra2) $(DISTFILES.common.extra3) 73 | DISTFILES = $(DISTFILES.common) Makevars POTFILES.in \ 74 | $(POFILES) $(GMOFILES) \ 75 | $(DISTFILES.extra1) $(DISTFILES.extra2) $(DISTFILES.extra3) 76 | 77 | POTFILES = \ 78 | 79 | CATALOGS = @CATALOGS@ 80 | 81 | POFILESDEPS_ = $(srcdir)/$(DOMAIN).pot 82 | POFILESDEPS_yes = $(POFILESDEPS_) 83 | POFILESDEPS_no = 84 | POFILESDEPS = $(POFILESDEPS_$(PO_DEPENDS_ON_POT)) 85 | 86 | DISTFILESDEPS_ = update-po 87 | DISTFILESDEPS_yes = $(DISTFILESDEPS_) 88 | DISTFILESDEPS_no = 89 | DISTFILESDEPS = $(DISTFILESDEPS_$(DIST_DEPENDS_ON_UPDATE_PO)) 90 | 91 | # Makevars gets inserted here. (Don't remove this line!) 92 | 93 | all: all-@USE_NLS@ 94 | 95 | 96 | .SUFFIXES: 97 | .SUFFIXES: .po .gmo .sed .sin .nop .po-create .po-update 98 | 99 | # The .pot file, stamp-po, .po files, and .gmo files appear in release tarballs. 100 | # The GNU Coding Standards say in 101 | # : 102 | # "GNU distributions usually contain some files which are not source files 103 | # ... . Since these files normally appear in the source directory, they 104 | # should always appear in the source directory, not in the build directory. 105 | # So Makefile rules to update them should put the updated files in the 106 | # source directory." 107 | # Therefore we put these files in the source directory, not the build directory. 108 | 109 | # During .po -> .gmo conversion, take into account the most recent changes to 110 | # the .pot file. This eliminates the need to update the .po files when the 111 | # .pot file has changed, which would be troublesome if the .po files are put 112 | # under version control. 113 | $(GMOFILES): $(srcdir)/$(DOMAIN).pot 114 | .po.gmo: 115 | @lang=`echo $* | sed -e 's,.*/,,'`; \ 116 | test "$(srcdir)" = . && cdcmd="" || cdcmd="cd $(srcdir) && "; \ 117 | echo "$${cdcmd}rm -f $${lang}.gmo && $(MSGMERGE) $(MSGMERGE_FOR_MSGFMT_OPTION) -o $${lang}.1po $${lang}.po $(DOMAIN).pot && $(GMSGFMT) -c --statistics --verbose -o $${lang}.gmo $${lang}.1po && rm -f $${lang}.1po"; \ 118 | cd $(srcdir) && \ 119 | rm -f $${lang}.gmo && \ 120 | $(MSGMERGE) $(MSGMERGE_FOR_MSGFMT_OPTION) -o $${lang}.1po $${lang}.po $(DOMAIN).pot && \ 121 | $(GMSGFMT) -c --statistics --verbose -o t-$${lang}.gmo $${lang}.1po && \ 122 | mv t-$${lang}.gmo $${lang}.gmo && \ 123 | rm -f $${lang}.1po 124 | 125 | .sin.sed: 126 | sed -e '/^#/d' $< > t-$@ 127 | mv t-$@ $@ 128 | 129 | 130 | all-yes: $(srcdir)/stamp-po 131 | all-no: 132 | 133 | # Ensure that the gettext macros and this Makefile.in.in are in sync. 134 | CHECK_MACRO_VERSION = \ 135 | test "$(GETTEXT_MACRO_VERSION)" = "@GETTEXT_MACRO_VERSION@" \ 136 | || { echo "*** error: gettext infrastructure mismatch: using a Makefile.in.in from gettext version $(GETTEXT_MACRO_VERSION) but the autoconf macros are from gettext version @GETTEXT_MACRO_VERSION@" 1>&2; \ 137 | exit 1; \ 138 | } 139 | 140 | # $(srcdir)/$(DOMAIN).pot is only created when needed. When xgettext finds no 141 | # internationalized messages, no $(srcdir)/$(DOMAIN).pot is created (because 142 | # we don't want to bother translators with empty POT files). We assume that 143 | # LINGUAS is empty in this case, i.e. $(POFILES) and $(GMOFILES) are empty. 144 | # In this case, $(srcdir)/stamp-po is a nop (i.e. a phony target). 145 | 146 | # $(srcdir)/stamp-po is a timestamp denoting the last time at which the CATALOGS 147 | # have been loosely updated. Its purpose is that when a developer or translator 148 | # checks out the package from a version control system, and the $(DOMAIN).pot 149 | # file is not under version control, "make" will update the $(DOMAIN).pot and 150 | # the $(CATALOGS), but subsequent invocations of "make" will do nothing. This 151 | # timestamp would not be necessary if updating the $(CATALOGS) would always 152 | # touch them; however, the rule for $(POFILES) has been designed to not touch 153 | # files that don't need to be changed. 154 | $(srcdir)/stamp-po: $(srcdir)/$(DOMAIN).pot 155 | @$(CHECK_MACRO_VERSION) 156 | test ! -f $(srcdir)/$(DOMAIN).pot || \ 157 | test -z "$(GMOFILES)" || $(MAKE) $(GMOFILES) 158 | @test ! -f $(srcdir)/$(DOMAIN).pot || { \ 159 | echo "touch $(srcdir)/stamp-po" && \ 160 | echo timestamp > $(srcdir)/stamp-poT && \ 161 | mv $(srcdir)/stamp-poT $(srcdir)/stamp-po; \ 162 | } 163 | 164 | # Note: Target 'all' must not depend on target '$(DOMAIN).pot-update', 165 | # otherwise packages like GCC can not be built if only parts of the source 166 | # have been downloaded. 167 | 168 | # This target rebuilds $(DOMAIN).pot; it is an expensive operation. 169 | # Note that $(DOMAIN).pot is not touched if it doesn't need to be changed. 170 | # The determination of whether the package xyz is a GNU one is based on the 171 | # heuristic whether some file in the top level directory mentions "GNU xyz". 172 | # If GNU 'find' is available, we avoid grepping through monster files. 173 | $(DOMAIN).pot-update: $(POTFILES) $(srcdir)/POTFILES.in remove-potcdate.sed 174 | package_gnu="$(PACKAGE_GNU)"; \ 175 | test -n "$$package_gnu" || { \ 176 | if { if (LC_ALL=C find --version) 2>/dev/null | grep GNU >/dev/null; then \ 177 | LC_ALL=C find -L $(top_srcdir) -maxdepth 1 -type f -size -10000000c -exec grep -i 'GNU @PACKAGE@' /dev/null '{}' ';' 2>/dev/null; \ 178 | else \ 179 | LC_ALL=C grep -i 'GNU @PACKAGE@' $(top_srcdir)/* 2>/dev/null; \ 180 | fi; \ 181 | } | grep -v 'libtool:' >/dev/null; then \ 182 | package_gnu=yes; \ 183 | else \ 184 | package_gnu=no; \ 185 | fi; \ 186 | }; \ 187 | if test "$$package_gnu" = "yes"; then \ 188 | package_prefix='GNU '; \ 189 | else \ 190 | package_prefix=''; \ 191 | fi; \ 192 | if test -n '$(MSGID_BUGS_ADDRESS)' || test '$(PACKAGE_BUGREPORT)' = '@'PACKAGE_BUGREPORT'@'; then \ 193 | msgid_bugs_address='$(MSGID_BUGS_ADDRESS)'; \ 194 | else \ 195 | msgid_bugs_address='$(PACKAGE_BUGREPORT)'; \ 196 | fi; \ 197 | case `$(XGETTEXT) --version | sed 1q | sed -e 's,^[^0-9]*,,'` in \ 198 | '' | 0.[0-9] | 0.[0-9].* | 0.1[0-5] | 0.1[0-5].* | 0.16 | 0.16.[0-1]*) \ 199 | $(XGETTEXT) --default-domain=$(DOMAIN) --directory=$(top_srcdir) \ 200 | --add-comments=TRANSLATORS: \ 201 | --files-from=$(srcdir)/POTFILES.in \ 202 | --copyright-holder='$(COPYRIGHT_HOLDER)' \ 203 | --msgid-bugs-address="$$msgid_bugs_address" \ 204 | $(XGETTEXT_OPTIONS) @XGETTEXT_EXTRA_OPTIONS@ \ 205 | ;; \ 206 | *) \ 207 | $(XGETTEXT) --default-domain=$(DOMAIN) --directory=$(top_srcdir) \ 208 | --add-comments=TRANSLATORS: \ 209 | --files-from=$(srcdir)/POTFILES.in \ 210 | --copyright-holder='$(COPYRIGHT_HOLDER)' \ 211 | --package-name="$${package_prefix}@PACKAGE@" \ 212 | --package-version='@VERSION@' \ 213 | --msgid-bugs-address="$$msgid_bugs_address" \ 214 | $(XGETTEXT_OPTIONS) @XGETTEXT_EXTRA_OPTIONS@ \ 215 | ;; \ 216 | esac 217 | test ! -f $(DOMAIN).po || { \ 218 | if test -f $(srcdir)/$(DOMAIN).pot-header; then \ 219 | sed -e '1,/^#$$/d' < $(DOMAIN).po > $(DOMAIN).1po && \ 220 | cat $(srcdir)/$(DOMAIN).pot-header $(DOMAIN).1po > $(DOMAIN).po && \ 221 | rm -f $(DOMAIN).1po \ 222 | || exit 1; \ 223 | fi; \ 224 | if test -f $(srcdir)/$(DOMAIN).pot; then \ 225 | sed -f remove-potcdate.sed < $(srcdir)/$(DOMAIN).pot > $(DOMAIN).1po && \ 226 | sed -f remove-potcdate.sed < $(DOMAIN).po > $(DOMAIN).2po && \ 227 | if cmp $(DOMAIN).1po $(DOMAIN).2po >/dev/null 2>&1; then \ 228 | rm -f $(DOMAIN).1po $(DOMAIN).2po $(DOMAIN).po; \ 229 | else \ 230 | rm -f $(DOMAIN).1po $(DOMAIN).2po $(srcdir)/$(DOMAIN).pot && \ 231 | mv $(DOMAIN).po $(srcdir)/$(DOMAIN).pot; \ 232 | fi; \ 233 | else \ 234 | mv $(DOMAIN).po $(srcdir)/$(DOMAIN).pot; \ 235 | fi; \ 236 | } 237 | 238 | # This rule has no dependencies: we don't need to update $(DOMAIN).pot at 239 | # every "make" invocation, only create it when it is missing. 240 | # Only "make $(DOMAIN).pot-update" or "make dist" will force an update. 241 | $(srcdir)/$(DOMAIN).pot: 242 | $(MAKE) $(DOMAIN).pot-update 243 | 244 | # This target rebuilds a PO file if $(DOMAIN).pot has changed. 245 | # Note that a PO file is not touched if it doesn't need to be changed. 246 | $(POFILES): $(POFILESDEPS) 247 | @test -f $(srcdir)/$(DOMAIN).pot || $(MAKE) $(srcdir)/$(DOMAIN).pot 248 | @lang=`echo $@ | sed -e 's,.*/,,' -e 's/\.po$$//'`; \ 249 | if test -f "$(srcdir)/$${lang}.po"; then \ 250 | test "$(srcdir)" = . && cdcmd="" || cdcmd="cd $(srcdir) && "; \ 251 | echo "$${cdcmd}$(MSGMERGE_UPDATE) $(MSGMERGE_OPTIONS) --lang=$${lang} --previous $${lang}.po $(DOMAIN).pot"; \ 252 | cd $(srcdir) \ 253 | && { case `$(MSGMERGE_UPDATE) --version | sed 1q | sed -e 's,^[^0-9]*,,'` in \ 254 | '' | 0.[0-9] | 0.[0-9].* | 0.1[0-5] | 0.1[0-5].*) \ 255 | $(MSGMERGE_UPDATE) $(MSGMERGE_OPTIONS) $${lang}.po $(DOMAIN).pot;; \ 256 | 0.1[6-7] | 0.1[6-7].*) \ 257 | $(MSGMERGE_UPDATE) $(MSGMERGE_OPTIONS) --previous $${lang}.po $(DOMAIN).pot;; \ 258 | *) \ 259 | $(MSGMERGE_UPDATE) $(MSGMERGE_OPTIONS) --lang=$${lang} --previous $${lang}.po $(DOMAIN).pot;; \ 260 | esac; \ 261 | }; \ 262 | else \ 263 | $(MAKE) $${lang}.po-create; \ 264 | fi 265 | 266 | 267 | install: install-exec install-data 268 | install-exec: 269 | install-data: install-data-@USE_NLS@ 270 | if test "$(PACKAGE)" = "gettext-tools"; then \ 271 | $(mkdir_p) $(DESTDIR)$(gettextsrcdir); \ 272 | for file in $(DISTFILES.common) Makevars.template; do \ 273 | $(INSTALL_DATA) $(srcdir)/$$file \ 274 | $(DESTDIR)$(gettextsrcdir)/$$file; \ 275 | done; \ 276 | for file in Makevars; do \ 277 | rm -f $(DESTDIR)$(gettextsrcdir)/$$file; \ 278 | done; \ 279 | else \ 280 | : ; \ 281 | fi 282 | install-data-no: all 283 | install-data-yes: all 284 | @catalogs='$(CATALOGS)'; \ 285 | for cat in $$catalogs; do \ 286 | cat=`basename $$cat`; \ 287 | lang=`echo $$cat | sed -e 's/\.gmo$$//'`; \ 288 | dir=$(localedir)/$$lang/LC_MESSAGES; \ 289 | $(mkdir_p) $(DESTDIR)$$dir; \ 290 | if test -r $$cat; then realcat=$$cat; else realcat=$(srcdir)/$$cat; fi; \ 291 | $(INSTALL_DATA) $$realcat $(DESTDIR)$$dir/$(DOMAIN).mo; \ 292 | echo "installing $$realcat as $(DESTDIR)$$dir/$(DOMAIN).mo"; \ 293 | for lc in '' $(EXTRA_LOCALE_CATEGORIES); do \ 294 | if test -n "$$lc"; then \ 295 | if (cd $(DESTDIR)$(localedir)/$$lang && LC_ALL=C ls -l -d $$lc 2>/dev/null) | grep ' -> ' >/dev/null; then \ 296 | link=`cd $(DESTDIR)$(localedir)/$$lang && LC_ALL=C ls -l -d $$lc | sed -e 's/^.* -> //'`; \ 297 | mv $(DESTDIR)$(localedir)/$$lang/$$lc $(DESTDIR)$(localedir)/$$lang/$$lc.old; \ 298 | mkdir $(DESTDIR)$(localedir)/$$lang/$$lc; \ 299 | (cd $(DESTDIR)$(localedir)/$$lang/$$lc.old && \ 300 | for file in *; do \ 301 | if test -f $$file; then \ 302 | ln -s ../$$link/$$file $(DESTDIR)$(localedir)/$$lang/$$lc/$$file; \ 303 | fi; \ 304 | done); \ 305 | rm -f $(DESTDIR)$(localedir)/$$lang/$$lc.old; \ 306 | else \ 307 | if test -d $(DESTDIR)$(localedir)/$$lang/$$lc; then \ 308 | :; \ 309 | else \ 310 | rm -f $(DESTDIR)$(localedir)/$$lang/$$lc; \ 311 | mkdir $(DESTDIR)$(localedir)/$$lang/$$lc; \ 312 | fi; \ 313 | fi; \ 314 | rm -f $(DESTDIR)$(localedir)/$$lang/$$lc/$(DOMAIN).mo; \ 315 | ln -s ../LC_MESSAGES/$(DOMAIN).mo $(DESTDIR)$(localedir)/$$lang/$$lc/$(DOMAIN).mo 2>/dev/null || \ 316 | ln $(DESTDIR)$(localedir)/$$lang/LC_MESSAGES/$(DOMAIN).mo $(DESTDIR)$(localedir)/$$lang/$$lc/$(DOMAIN).mo 2>/dev/null || \ 317 | cp -p $(DESTDIR)$(localedir)/$$lang/LC_MESSAGES/$(DOMAIN).mo $(DESTDIR)$(localedir)/$$lang/$$lc/$(DOMAIN).mo; \ 318 | echo "installing $$realcat link as $(DESTDIR)$(localedir)/$$lang/$$lc/$(DOMAIN).mo"; \ 319 | fi; \ 320 | done; \ 321 | done 322 | 323 | install-strip: install 324 | 325 | installdirs: installdirs-exec installdirs-data 326 | installdirs-exec: 327 | installdirs-data: installdirs-data-@USE_NLS@ 328 | if test "$(PACKAGE)" = "gettext-tools"; then \ 329 | $(mkdir_p) $(DESTDIR)$(gettextsrcdir); \ 330 | else \ 331 | : ; \ 332 | fi 333 | installdirs-data-no: 334 | installdirs-data-yes: 335 | @catalogs='$(CATALOGS)'; \ 336 | for cat in $$catalogs; do \ 337 | cat=`basename $$cat`; \ 338 | lang=`echo $$cat | sed -e 's/\.gmo$$//'`; \ 339 | dir=$(localedir)/$$lang/LC_MESSAGES; \ 340 | $(mkdir_p) $(DESTDIR)$$dir; \ 341 | for lc in '' $(EXTRA_LOCALE_CATEGORIES); do \ 342 | if test -n "$$lc"; then \ 343 | if (cd $(DESTDIR)$(localedir)/$$lang && LC_ALL=C ls -l -d $$lc 2>/dev/null) | grep ' -> ' >/dev/null; then \ 344 | link=`cd $(DESTDIR)$(localedir)/$$lang && LC_ALL=C ls -l -d $$lc | sed -e 's/^.* -> //'`; \ 345 | mv $(DESTDIR)$(localedir)/$$lang/$$lc $(DESTDIR)$(localedir)/$$lang/$$lc.old; \ 346 | mkdir $(DESTDIR)$(localedir)/$$lang/$$lc; \ 347 | (cd $(DESTDIR)$(localedir)/$$lang/$$lc.old && \ 348 | for file in *; do \ 349 | if test -f $$file; then \ 350 | ln -s ../$$link/$$file $(DESTDIR)$(localedir)/$$lang/$$lc/$$file; \ 351 | fi; \ 352 | done); \ 353 | rm -f $(DESTDIR)$(localedir)/$$lang/$$lc.old; \ 354 | else \ 355 | if test -d $(DESTDIR)$(localedir)/$$lang/$$lc; then \ 356 | :; \ 357 | else \ 358 | rm -f $(DESTDIR)$(localedir)/$$lang/$$lc; \ 359 | mkdir $(DESTDIR)$(localedir)/$$lang/$$lc; \ 360 | fi; \ 361 | fi; \ 362 | fi; \ 363 | done; \ 364 | done 365 | 366 | # Define this as empty until I found a useful application. 367 | installcheck: 368 | 369 | uninstall: uninstall-exec uninstall-data 370 | uninstall-exec: 371 | uninstall-data: uninstall-data-@USE_NLS@ 372 | if test "$(PACKAGE)" = "gettext-tools"; then \ 373 | for file in $(DISTFILES.common) Makevars.template; do \ 374 | rm -f $(DESTDIR)$(gettextsrcdir)/$$file; \ 375 | done; \ 376 | else \ 377 | : ; \ 378 | fi 379 | uninstall-data-no: 380 | uninstall-data-yes: 381 | catalogs='$(CATALOGS)'; \ 382 | for cat in $$catalogs; do \ 383 | cat=`basename $$cat`; \ 384 | lang=`echo $$cat | sed -e 's/\.gmo$$//'`; \ 385 | for lc in LC_MESSAGES $(EXTRA_LOCALE_CATEGORIES); do \ 386 | rm -f $(DESTDIR)$(localedir)/$$lang/$$lc/$(DOMAIN).mo; \ 387 | done; \ 388 | done 389 | 390 | check: all 391 | 392 | info dvi ps pdf html tags TAGS ctags CTAGS ID: 393 | 394 | install-dvi install-ps install-pdf install-html: 395 | 396 | mostlyclean: 397 | rm -f remove-potcdate.sed 398 | rm -f $(srcdir)/stamp-poT 399 | rm -f core core.* $(DOMAIN).po $(DOMAIN).1po $(DOMAIN).2po *.new.po 400 | rm -fr *.o 401 | 402 | clean: mostlyclean 403 | 404 | distclean: clean 405 | rm -f Makefile Makefile.in POTFILES 406 | 407 | maintainer-clean: distclean 408 | @echo "This command is intended for maintainers to use;" 409 | @echo "it deletes files that may require special tools to rebuild." 410 | rm -f $(srcdir)/$(DOMAIN).pot $(srcdir)/stamp-po $(GMOFILES) 411 | 412 | distdir = $(top_builddir)/$(PACKAGE)-$(VERSION)/$(subdir) 413 | dist distdir: 414 | test -z "$(DISTFILESDEPS)" || $(MAKE) $(DISTFILESDEPS) 415 | @$(MAKE) dist2 416 | # This is a separate target because 'update-po' must be executed before. 417 | dist2: $(srcdir)/stamp-po $(DISTFILES) 418 | @dists="$(DISTFILES)"; \ 419 | if test "$(PACKAGE)" = "gettext-tools"; then \ 420 | dists="$$dists Makevars.template"; \ 421 | fi; \ 422 | if test -f $(srcdir)/$(DOMAIN).pot; then \ 423 | dists="$$dists $(DOMAIN).pot stamp-po"; \ 424 | else \ 425 | case $(XGETTEXT) in \ 426 | :) echo "Warning: Creating a tarball without '$(DOMAIN).pot', because a suitable 'xgettext' program was not found in PATH." 1>&2;; \ 427 | *) echo "Warning: Creating a tarball without '$(DOMAIN).pot', because 'xgettext' found no strings to extract. Check the contents of the POTFILES.in file and the XGETTEXT_OPTIONS in the Makevars file." 1>&2;; \ 428 | esac; \ 429 | fi; \ 430 | if test -f $(srcdir)/ChangeLog; then \ 431 | dists="$$dists ChangeLog"; \ 432 | fi; \ 433 | for i in 0 1 2 3 4 5 6 7 8 9; do \ 434 | if test -f $(srcdir)/ChangeLog.$$i; then \ 435 | dists="$$dists ChangeLog.$$i"; \ 436 | fi; \ 437 | done; \ 438 | if test -f $(srcdir)/LINGUAS; then dists="$$dists LINGUAS"; fi; \ 439 | for file in $$dists; do \ 440 | if test -f $$file; then \ 441 | cp -p $$file $(distdir) || exit 1; \ 442 | else \ 443 | cp -p $(srcdir)/$$file $(distdir) || exit 1; \ 444 | fi; \ 445 | done 446 | 447 | update-po: Makefile 448 | $(MAKE) $(DOMAIN).pot-update 449 | test -z "$(UPDATEPOFILES)" || $(MAKE) $(UPDATEPOFILES) 450 | $(MAKE) update-gmo 451 | 452 | # General rule for creating PO files. 453 | 454 | .nop.po-create: 455 | @lang=`echo $@ | sed -e 's/\.po-create$$//'`; \ 456 | echo "File $$lang.po does not exist. If you are a translator, you can create it through 'msginit'." 1>&2; \ 457 | exit 1 458 | 459 | # General rule for updating PO files. 460 | 461 | .nop.po-update: 462 | @lang=`echo $@ | sed -e 's/\.po-update$$//'`; \ 463 | if test "$(PACKAGE)" = "gettext-tools" && test "$(CROSS_COMPILING)" != "yes"; then PATH=`pwd`/../src:$$PATH; fi; \ 464 | tmpdir=`pwd`; \ 465 | echo "$$lang:"; \ 466 | test "$(srcdir)" = . && cdcmd="" || cdcmd="cd $(srcdir) && "; \ 467 | echo "$${cdcmd}$(MSGMERGE) $(MSGMERGE_OPTIONS) --lang=$$lang --previous $$lang.po $(DOMAIN).pot -o $$lang.new.po"; \ 468 | cd $(srcdir); \ 469 | if { case `$(MSGMERGE) --version | sed 1q | sed -e 's,^[^0-9]*,,'` in \ 470 | '' | 0.[0-9] | 0.[0-9].* | 0.1[0-5] | 0.1[0-5].*) \ 471 | $(MSGMERGE) $(MSGMERGE_OPTIONS) -o $$tmpdir/$$lang.new.po $$lang.po $(DOMAIN).pot;; \ 472 | 0.1[6-7] | 0.1[6-7].*) \ 473 | $(MSGMERGE) $(MSGMERGE_OPTIONS) --previous -o $$tmpdir/$$lang.new.po $$lang.po $(DOMAIN).pot;; \ 474 | *) \ 475 | $(MSGMERGE) $(MSGMERGE_OPTIONS) --lang=$$lang --previous -o $$tmpdir/$$lang.new.po $$lang.po $(DOMAIN).pot;; \ 476 | esac; \ 477 | }; then \ 478 | if cmp $$lang.po $$tmpdir/$$lang.new.po >/dev/null 2>&1; then \ 479 | rm -f $$tmpdir/$$lang.new.po; \ 480 | else \ 481 | if mv -f $$tmpdir/$$lang.new.po $$lang.po; then \ 482 | :; \ 483 | else \ 484 | echo "msgmerge for $$lang.po failed: cannot move $$tmpdir/$$lang.new.po to $$lang.po" 1>&2; \ 485 | exit 1; \ 486 | fi; \ 487 | fi; \ 488 | else \ 489 | echo "msgmerge for $$lang.po failed!" 1>&2; \ 490 | rm -f $$tmpdir/$$lang.new.po; \ 491 | fi 492 | 493 | $(DUMMYPOFILES): 494 | 495 | update-gmo: Makefile $(GMOFILES) 496 | @: 497 | 498 | # Recreate Makefile by invoking config.status. Explicitly invoke the shell, 499 | # because execution permission bits may not work on the current file system. 500 | # Use @SHELL@, which is the shell determined by autoconf for the use by its 501 | # scripts, not $(SHELL) which is hardwired to /bin/sh and may be deficient. 502 | Makefile: Makefile.in.in Makevars $(top_builddir)/config.status @POMAKEFILEDEPS@ 503 | cd $(top_builddir) \ 504 | && @SHELL@ ./config.status $(subdir)/$@.in po-directories 505 | 506 | force: 507 | 508 | # Tell versions [3.59,3.63) of GNU make not to export all variables. 509 | # Otherwise a system limit (for SysV at least) may be exceeded. 510 | .NOEXPORT: 511 | -------------------------------------------------------------------------------- /po/Makevars: -------------------------------------------------------------------------------- 1 | # Makefile variables for PO directory in any package using GNU gettext. 2 | # 3 | # Copyright (C) 2003-2019 Free Software Foundation, Inc. 4 | # This file is free software; the Free Software Foundation gives 5 | # unlimited permission to use, copy, distribute, and modify it. 6 | 7 | # Usually the message domain is the same as the package name. 8 | DOMAIN = $(PACKAGE) 9 | 10 | # These two variables depend on the location of this directory. 11 | subdir = po 12 | top_builddir = .. 13 | 14 | # These options get passed to xgettext. 15 | XGETTEXT_OPTIONS = --from-code=UTF-8 --keyword=G_ --keyword=N_ 16 | 17 | # This is the copyright holder that gets inserted into the header of the 18 | # $(DOMAIN).pot file. Set this to the copyright holder of the surrounding 19 | # package. (Note that the msgstr strings, extracted from the package's 20 | # sources, belong to the copyright holder of the package.) Translators are 21 | # expected to transfer the copyright for their translations to this person 22 | # or entity, or to disclaim their copyright. The empty string stands for 23 | # the public domain; in this case the translators are expected to disclaim 24 | # their copyright. 25 | COPYRIGHT_HOLDER = Zheng Junjie 26 | 27 | # This tells whether or not to prepend "GNU " prefix to the package 28 | # name that gets inserted into the header of the $(DOMAIN).pot file. 29 | # Possible values are "yes", "no", or empty. If it is empty, try to 30 | # detect it automatically by scanning the files in $(top_srcdir) for 31 | # "GNU packagename" string. 32 | PACKAGE_GNU = 33 | 34 | # This is the email address or URL to which the translators shall report 35 | # bugs in the untranslated strings: 36 | # - Strings which are not entire sentences, see the maintainer guidelines 37 | # in the GNU gettext documentation, section 'Preparing Strings'. 38 | # - Strings which use unclear terms or require additional context to be 39 | # understood. 40 | # - Strings which make invalid assumptions about notation of date, time or 41 | # money. 42 | # - Pluralisation problems. 43 | # - Incorrect English spelling. 44 | # - Incorrect formatting. 45 | # It can be your email address, or a mailing list address where translators 46 | # can write to without being subscribed, or the URL of a web page through 47 | # which the translators can contact you. 48 | MSGID_BUGS_ADDRESS = $(PACKAGE_BUGREPORT) 49 | 50 | # This is the list of locale categories, beyond LC_MESSAGES, for which the 51 | # message catalogs shall be used. It is usually empty. 52 | EXTRA_LOCALE_CATEGORIES = 53 | 54 | # This tells whether the $(DOMAIN).pot file contains messages with an 'msgctxt' 55 | # context. Possible values are "yes" and "no". Set this to yes if the 56 | # package uses functions taking also a message context, like pgettext(), or 57 | # if in $(XGETTEXT_OPTIONS) you define keywords with a context argument. 58 | USE_MSGCTXT = no 59 | 60 | # These options get passed to msgmerge. 61 | # Useful options are in particular: 62 | # --previous to keep previous msgids of translated messages, 63 | # --quiet to reduce the verbosity. 64 | MSGMERGE_OPTIONS = 65 | 66 | # These options get passed to msginit. 67 | # If you want to disable line wrapping when writing PO files, add 68 | # --no-wrap to MSGMERGE_OPTIONS, XGETTEXT_OPTIONS, and 69 | # MSGINIT_OPTIONS. 70 | MSGINIT_OPTIONS = 71 | 72 | # This tells whether or not to regenerate a PO file when $(DOMAIN).pot 73 | # has changed. Possible values are "yes" and "no". Set this to no if 74 | # the POT file is checked in the repository and the version control 75 | # program ignores timestamps. 76 | PO_DEPENDS_ON_POT = yes 77 | 78 | # This tells whether or not to forcibly update $(DOMAIN).pot and 79 | # regenerate PO files on "make dist". Possible values are "yes" and 80 | # "no". Set this to no if the POT file and PO files are maintained 81 | # externally. 82 | DIST_DEPENDS_ON_UPDATE_PO = yes 83 | -------------------------------------------------------------------------------- /po/POTFILES.in: -------------------------------------------------------------------------------- 1 | # List of source files which contain translatable strings. 2 | gwwm.scm 3 | gwwm/command.scm 4 | gwwm/i18n.scm 5 | gwwm/keymap.scm 6 | gwwm/config.scm 7 | gwwm/client.scm 8 | gwwm/color.scm 9 | gwwm/commands.scm 10 | gwwm/keys.scm 11 | gwwm/monitor.scm 12 | gwwm/utils.scm 13 | gwwm/keybind.scm 14 | gwwm/keyboard.scm 15 | -------------------------------------------------------------------------------- /po/gwwm.pot: -------------------------------------------------------------------------------- 1 | # SOME DESCRIPTIVE TITLE. 2 | # Copyright (C) YEAR Zheng Junjie 3 | # This file is distributed under the same license as the gwwm package. 4 | # FIRST AUTHOR , YEAR. 5 | # 6 | #, fuzzy 7 | msgid "" 8 | msgstr "" 9 | "Project-Id-Version: gwwm 0.0.1\n" 10 | "Report-Msgid-Bugs-To: 873216071@qq.com\n" 11 | "POT-Creation-Date: 2022-09-12 21:29+0800\n" 12 | "PO-Revision-Date: YEAR-MO-DA HO:MI+ZONE\n" 13 | "Last-Translator: FULL NAME \n" 14 | "Language-Team: LANGUAGE \n" 15 | "Language: \n" 16 | "MIME-Version: 1.0\n" 17 | "Content-Type: text/plain; charset=CHARSET\n" 18 | "Content-Transfer-Encoding: 8bit\n" 19 | 20 | #: gwwm.scm:76 21 | msgid "" 22 | "gwwm [options]\n" 23 | " -v --version Display version\n" 24 | " -h --help Display this help\n" 25 | msgstr "" 26 | 27 | #: gwwm.scm:93 28 | msgid "wl-display-add-socket-auto fail." 29 | msgstr "" 30 | 31 | #: gwwm.scm:134 32 | msgid "XDG_RUNTIME_DIR must be set." 33 | msgstr "" 34 | 35 | #: gwwm.scm:146 36 | msgid "backend is started." 37 | msgstr "" 38 | 39 | #: gwwm.scm:147 40 | msgid "gwwm cannot start backend!" 41 | msgstr "" 42 | 43 | #: gwwm/keymap.scm:72 44 | msgid "for now, gwwm not support multi key define, ignore others." 45 | msgstr "" 46 | 47 | #: gwwm/config.scm:45 48 | msgid "initfile not found:" 49 | msgstr "" 50 | 51 | #: gwwm/config.scm:92 52 | #, scheme-format 53 | msgid "unknow init-keyword!: ~s" 54 | msgstr "" 55 | 56 | #: gwwm/client.scm:77 57 | #, scheme-format 58 | msgid "~S is a *deaded* client.~%" 59 | msgstr "" 60 | 61 | #: gwwm/utils.scm:10 62 | #, scheme-format 63 | msgid "" 64 | "~S is a hashtable, value is:~%~:{\t~s => ~s\n" 65 | "~}.~%" 66 | msgstr "" 67 | -------------------------------------------------------------------------------- /po/zh_CN.po: -------------------------------------------------------------------------------- 1 | # Chinese translations for gwwm package. 2 | # Copyright (C) 2022 Zheng Junjie 3 | # This file is distributed under the same license as the gwwm package. 4 | # Z572 <873216071@qq.com>, 2022. 5 | # 6 | msgid "" 7 | msgstr "" 8 | "Project-Id-Version: gwwm 0.0.1\n" 9 | "Report-Msgid-Bugs-To: 873216071@qq.com\n" 10 | "POT-Creation-Date: 2022-09-12 21:29+0800\n" 11 | "PO-Revision-Date: 2022-09-12 21:30+0800\n" 12 | "Last-Translator: Z572 <873216071@qq.com>\n" 13 | "Language-Team: Chinese (simplified) \n" 14 | "Language: zh_CN\n" 15 | "MIME-Version: 1.0\n" 16 | "Content-Type: text/plain; charset=UTF-8\n" 17 | "Content-Transfer-Encoding: 8bit\n" 18 | 19 | #: gwwm.scm:76 20 | msgid "" 21 | "gwwm [options]\n" 22 | " -v --version Display version\n" 23 | " -h --help Display this help\n" 24 | msgstr "" 25 | "gwwm [选项]\n" 26 | " -v --version 显示版本\n" 27 | " -h --help 显示本帮助\n" 28 | 29 | #: gwwm.scm:93 30 | msgid "wl-display-add-socket-auto fail." 31 | msgstr "wl-display-add-socket-auto 失败." 32 | 33 | #: gwwm.scm:134 34 | msgid "XDG_RUNTIME_DIR must be set." 35 | msgstr "必须设置 XDG_RUNTIME_DIR 环境变量." 36 | 37 | #: gwwm.scm:146 38 | msgid "backend is started." 39 | msgstr "后端已启动." 40 | 41 | #: gwwm.scm:147 42 | msgid "gwwm cannot start backend!" 43 | msgstr "gwwm 无法启动后端" 44 | 45 | #: gwwm/keymap.scm:72 46 | msgid "for now, gwwm not support multi key define, ignore others." 47 | msgstr "在当前, gwwm 不支持多键定义,忽略后面的键." 48 | 49 | #: gwwm/config.scm:45 50 | msgid "initfile not found:" 51 | msgstr "配置文件未找到" 52 | 53 | #: gwwm/config.scm:92 54 | #, scheme-format 55 | msgid "unknow init-keyword!: ~s" 56 | msgstr "未知 init-keyword !: ~s" 57 | 58 | #: gwwm/client.scm:77 59 | #, scheme-format 60 | msgid "~S is a *deaded* client.~%" 61 | msgstr "~S 是个死去的客户端.~%" 62 | 63 | #: gwwm/utils.scm:10 64 | #, scheme-format 65 | msgid "" 66 | "~S is a hashtable, value is:~%~:{\t~s => ~s\n" 67 | "~}.~%" 68 | msgstr "" 69 | -------------------------------------------------------------------------------- /pre-inst-env.in: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | abs_top_srcdir="`cd "@abs_top_srcdir@" > /dev/null; pwd`" 4 | abs_top_builddir="`cd "@abs_top_builddir@" > /dev/null; pwd`" 5 | 6 | GUILE_LOAD_COMPILED_PATH="$abs_top_builddir:${GUILE_LOAD_COMPILED_PATH:+:}$GUILE_LOAD_COMPILED_PATH" 7 | GUILE_LOAD_PATH="$abs_top_builddir:$GUILE_LOAD_PATH" 8 | GUILE_AUTO_COMPILE=0 9 | export GUILE_AUTO_COMPILE 10 | export GUILE_LOAD_COMPILED_PATH GUILE_LOAD_PATH 11 | LTDL_LIBRARY_PATH="$abs_top_builddir/.libs/" 12 | export LTDL_LIBRARY_PATH 13 | PATH="$abs_top_builddir/scripts:$abs_top_builddir:$PATH" 14 | export PATH 15 | 16 | exec "$@" 17 | -------------------------------------------------------------------------------- /protocols/idle.xml: -------------------------------------------------------------------------------- 1 | 2 | 3 | . 18 | ]]> 19 | 20 | 21 | This interface allows to monitor user idle time on a given seat. The interface 22 | allows to register timers which trigger after no user activity was registered 23 | on the seat for a given interval. It notifies when user activity resumes. 24 | 25 | This is useful for applications wanting to perform actions when the user is not 26 | interacting with the system, e.g. chat applications setting the user as away, power 27 | management features to dim screen, etc.. 28 | 29 | 30 | 31 | 32 | 33 | 34 | 35 | 36 | 37 | 38 | 39 | 40 | 41 | 42 | 43 | 44 | 45 | 46 | 47 | 48 | 49 | 50 | -------------------------------------------------------------------------------- /protocols/wlr-layer-shell-unstable-v1.xml: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | Copyright © 2017 Drew DeVault 5 | 6 | Permission to use, copy, modify, distribute, and sell this 7 | software and its documentation for any purpose is hereby granted 8 | without fee, provided that the above copyright notice appear in 9 | all copies and that both that copyright notice and this permission 10 | notice appear in supporting documentation, and that the name of 11 | the copyright holders not be used in advertising or publicity 12 | pertaining to distribution of the software without specific, 13 | written prior permission. The copyright holders make no 14 | representations about the suitability of this software for any 15 | purpose. It is provided "as is" without express or implied 16 | warranty. 17 | 18 | THE COPYRIGHT HOLDERS DISCLAIM ALL WARRANTIES WITH REGARD TO THIS 19 | SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND 20 | FITNESS, IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY 21 | SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 22 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN 23 | AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, 24 | ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF 25 | THIS SOFTWARE. 26 | 27 | 28 | 29 | 30 | Clients can use this interface to assign the surface_layer role to 31 | wl_surfaces. Such surfaces are assigned to a "layer" of the output and 32 | rendered with a defined z-depth respective to each other. They may also be 33 | anchored to the edges and corners of a screen and specify input handling 34 | semantics. This interface should be suitable for the implementation of 35 | many desktop shell components, and a broad number of other applications 36 | that interact with the desktop. 37 | 38 | 39 | 40 | 41 | Create a layer surface for an existing surface. This assigns the role of 42 | layer_surface, or raises a protocol error if another role is already 43 | assigned. 44 | 45 | Creating a layer surface from a wl_surface which has a buffer attached 46 | or committed is a client error, and any attempts by a client to attach 47 | or manipulate a buffer prior to the first layer_surface.configure call 48 | must also be treated as errors. 49 | 50 | After creating a layer_surface object and setting it up, the client 51 | must perform an initial commit without any buffer attached. 52 | The compositor will reply with a layer_surface.configure event. 53 | The client must acknowledge it and is then allowed to attach a buffer 54 | to map the surface. 55 | 56 | You may pass NULL for output to allow the compositor to decide which 57 | output to use. Generally this will be the one that the user most 58 | recently interacted with. 59 | 60 | Clients can specify a namespace that defines the purpose of the layer 61 | surface. 62 | 63 | 64 | 65 | 66 | 67 | 68 | 69 | 70 | 71 | 72 | 73 | 74 | 75 | 76 | 77 | 78 | These values indicate which layers a surface can be rendered in. They 79 | are ordered by z depth, bottom-most first. Traditional shell surfaces 80 | will typically be rendered between the bottom and top layers. 81 | Fullscreen shell surfaces are typically rendered at the top layer. 82 | Multiple surfaces can share a single layer, and ordering within a 83 | single layer is undefined. 84 | 85 | 86 | 87 | 88 | 89 | 90 | 91 | 92 | 93 | 94 | 95 | 96 | This request indicates that the client will not use the layer_shell 97 | object any more. Objects that have been created through this instance 98 | are not affected. 99 | 100 | 101 | 102 | 103 | 104 | 105 | An interface that may be implemented by a wl_surface, for surfaces that 106 | are designed to be rendered as a layer of a stacked desktop-like 107 | environment. 108 | 109 | Layer surface state (layer, size, anchor, exclusive zone, 110 | margin, interactivity) is double-buffered, and will be applied at the 111 | time wl_surface.commit of the corresponding wl_surface is called. 112 | 113 | Attaching a null buffer to a layer surface unmaps it. 114 | 115 | Unmapping a layer_surface means that the surface cannot be shown by the 116 | compositor until it is explicitly mapped again. The layer_surface 117 | returns to the state it had right after layer_shell.get_layer_surface. 118 | The client can re-map the surface by performing a commit without any 119 | buffer attached, waiting for a configure event and handling it as usual. 120 | 121 | 122 | 123 | 124 | Sets the size of the surface in surface-local coordinates. The 125 | compositor will display the surface centered with respect to its 126 | anchors. 127 | 128 | If you pass 0 for either value, the compositor will assign it and 129 | inform you of the assignment in the configure event. You must set your 130 | anchor to opposite edges in the dimensions you omit; not doing so is a 131 | protocol error. Both values are 0 by default. 132 | 133 | Size is double-buffered, see wl_surface.commit. 134 | 135 | 136 | 137 | 138 | 139 | 140 | 141 | Requests that the compositor anchor the surface to the specified edges 142 | and corners. If two orthogonal edges are specified (e.g. 'top' and 143 | 'left'), then the anchor point will be the intersection of the edges 144 | (e.g. the top left corner of the output); otherwise the anchor point 145 | will be centered on that edge, or in the center if none is specified. 146 | 147 | Anchor is double-buffered, see wl_surface.commit. 148 | 149 | 150 | 151 | 152 | 153 | 154 | Requests that the compositor avoids occluding an area with other 155 | surfaces. The compositor's use of this information is 156 | implementation-dependent - do not assume that this region will not 157 | actually be occluded. 158 | 159 | A positive value is only meaningful if the surface is anchored to one 160 | edge or an edge and both perpendicular edges. If the surface is not 161 | anchored, anchored to only two perpendicular edges (a corner), anchored 162 | to only two parallel edges or anchored to all edges, a positive value 163 | will be treated the same as zero. 164 | 165 | A positive zone is the distance from the edge in surface-local 166 | coordinates to consider exclusive. 167 | 168 | Surfaces that do not wish to have an exclusive zone may instead specify 169 | how they should interact with surfaces that do. If set to zero, the 170 | surface indicates that it would like to be moved to avoid occluding 171 | surfaces with a positive exclusive zone. If set to -1, the surface 172 | indicates that it would not like to be moved to accommodate for other 173 | surfaces, and the compositor should extend it all the way to the edges 174 | it is anchored to. 175 | 176 | For example, a panel might set its exclusive zone to 10, so that 177 | maximized shell surfaces are not shown on top of it. A notification 178 | might set its exclusive zone to 0, so that it is moved to avoid 179 | occluding the panel, but shell surfaces are shown underneath it. A 180 | wallpaper or lock screen might set their exclusive zone to -1, so that 181 | they stretch below or over the panel. 182 | 183 | The default value is 0. 184 | 185 | Exclusive zone is double-buffered, see wl_surface.commit. 186 | 187 | 188 | 189 | 190 | 191 | 192 | Requests that the surface be placed some distance away from the anchor 193 | point on the output, in surface-local coordinates. Setting this value 194 | for edges you are not anchored to has no effect. 195 | 196 | The exclusive zone includes the margin. 197 | 198 | Margin is double-buffered, see wl_surface.commit. 199 | 200 | 201 | 202 | 203 | 204 | 205 | 206 | 207 | 208 | Types of keyboard interaction possible for layer shell surfaces. The 209 | rationale for this is twofold: (1) some applications are not interested 210 | in keyboard events and not allowing them to be focused can improve the 211 | desktop experience; (2) some applications will want to take exclusive 212 | keyboard focus. 213 | 214 | 215 | 216 | 217 | This value indicates that this surface is not interested in keyboard 218 | events and the compositor should never assign it the keyboard focus. 219 | 220 | This is the default value, set for newly created layer shell surfaces. 221 | 222 | This is useful for e.g. desktop widgets that display information or 223 | only have interaction with non-keyboard input devices. 224 | 225 | 226 | 227 | 228 | Request exclusive keyboard focus if this surface is above the shell surface layer. 229 | 230 | For the top and overlay layers, the seat will always give 231 | exclusive keyboard focus to the top-most layer which has keyboard 232 | interactivity set to exclusive. If this layer contains multiple 233 | surfaces with keyboard interactivity set to exclusive, the compositor 234 | determines the one receiving keyboard events in an implementation- 235 | defined manner. In this case, no guarantee is made when this surface 236 | will receive keyboard focus (if ever). 237 | 238 | For the bottom and background layers, the compositor is allowed to use 239 | normal focus semantics. 240 | 241 | This setting is mainly intended for applications that need to ensure 242 | they receive all keyboard events, such as a lock screen or a password 243 | prompt. 244 | 245 | 246 | 247 | 248 | This requests the compositor to allow this surface to be focused and 249 | unfocused by the user in an implementation-defined manner. The user 250 | should be able to unfocus this surface even regardless of the layer 251 | it is on. 252 | 253 | Typically, the compositor will want to use its normal mechanism to 254 | manage keyboard focus between layer shell surfaces with this setting 255 | and regular toplevels on the desktop layer (e.g. click to focus). 256 | Nevertheless, it is possible for a compositor to require a special 257 | interaction to focus or unfocus layer shell surfaces (e.g. requiring 258 | a click even if focus follows the mouse normally, or providing a 259 | keybinding to switch focus between layers). 260 | 261 | This setting is mainly intended for desktop shell components (e.g. 262 | panels) that allow keyboard interaction. Using this option can allow 263 | implementing a desktop shell that can be fully usable without the 264 | mouse. 265 | 266 | 267 | 268 | 269 | 270 | 271 | Set how keyboard events are delivered to this surface. By default, 272 | layer shell surfaces do not receive keyboard events; this request can 273 | be used to change this. 274 | 275 | This setting is inherited by child surfaces set by the get_popup 276 | request. 277 | 278 | Layer surfaces receive pointer, touch, and tablet events normally. If 279 | you do not want to receive them, set the input region on your surface 280 | to an empty region. 281 | 282 | Keyboard interactivity is double-buffered, see wl_surface.commit. 283 | 284 | 285 | 286 | 287 | 288 | 289 | This assigns an xdg_popup's parent to this layer_surface. This popup 290 | should have been created via xdg_surface::get_popup with the parent set 291 | to NULL, and this request must be invoked before committing the popup's 292 | initial state. 293 | 294 | See the documentation of xdg_popup for more details about what an 295 | xdg_popup is and how it is used. 296 | 297 | 298 | 299 | 300 | 301 | 302 | When a configure event is received, if a client commits the 303 | surface in response to the configure event, then the client 304 | must make an ack_configure request sometime before the commit 305 | request, passing along the serial of the configure event. 306 | 307 | If the client receives multiple configure events before it 308 | can respond to one, it only has to ack the last configure event. 309 | 310 | A client is not required to commit immediately after sending 311 | an ack_configure request - it may even ack_configure several times 312 | before its next surface commit. 313 | 314 | A client may send multiple ack_configure requests before committing, but 315 | only the last request sent before a commit indicates which configure 316 | event the client really is responding to. 317 | 318 | 319 | 320 | 321 | 322 | 323 | This request destroys the layer surface. 324 | 325 | 326 | 327 | 328 | 329 | The configure event asks the client to resize its surface. 330 | 331 | Clients should arrange their surface for the new states, and then send 332 | an ack_configure request with the serial sent in this configure event at 333 | some point before committing the new surface. 334 | 335 | The client is free to dismiss all but the last configure event it 336 | received. 337 | 338 | The width and height arguments specify the size of the window in 339 | surface-local coordinates. 340 | 341 | The size is a hint, in the sense that the client is free to ignore it if 342 | it doesn't resize, pick a smaller size (to satisfy aspect ratio or 343 | resize in steps of NxM pixels). If the client picks a smaller size and 344 | is anchored to two opposite anchors (e.g. 'top' and 'bottom'), the 345 | surface will be centered on this axis. 346 | 347 | If the width or height arguments are zero, it means the client should 348 | decide its own window dimension. 349 | 350 | 351 | 352 | 353 | 354 | 355 | 356 | 357 | The closed event is sent by the compositor when the surface will no 358 | longer be shown. The output may have been destroyed or the user may 359 | have asked for it to be removed. Further changes to the surface will be 360 | ignored. The client should destroy the resource after receiving this 361 | event, and create a new surface if they so choose. 362 | 363 | 364 | 365 | 366 | 367 | 368 | 369 | 370 | 371 | 372 | 373 | 374 | 375 | 376 | 377 | 378 | 379 | 380 | 381 | 382 | 383 | Change the layer that the surface is rendered on. 384 | 385 | Layer is double-buffered, see wl_surface.commit. 386 | 387 | 388 | 389 | 390 | 391 | -------------------------------------------------------------------------------- /tests/config.scm: -------------------------------------------------------------------------------- 1 | (define-module (tests config) 2 | #:use-module (oop goops) 3 | #:use-module (srfi srfi-64) 4 | #:use-module (srfi srfi-189) 5 | #:use-module (gwwm utils srfi-215) 6 | #:use-module (gwwm config)) 7 | 8 | (current-log-callback 9 | (let ((p (current-error-port))) 10 | (lambda (msg) 11 | (let ((msg2 msg)) 12 | (format p "[~a]| ~a | " 13 | (cdr (assq 'SEVERITY msg)) 14 | (cdr (assq 'MESSAGE msg))) 15 | (set! msg2 (assoc-remove! (assoc-remove! msg2 'SEVERITY) 'MESSAGE)) 16 | (for-each (lambda (a) 17 | (display (car a) p) 18 | (display ":" p) 19 | (display (object->string(cdr a)) p) 20 | (display " " p)) 21 | msg2) 22 | (newline p))))) 23 | (define-config-option enable-debug? #t 24 | "a" 25 | #:conv (lambda (o) (->bool o))) 26 | 27 | (test-group "get-option-value" 28 | (test-equal "no exists" 29 | (nothing) 30 | (get-option-value b)) 31 | (test-equal "get" 32 | (just #t) 33 | (get-option-value enable-debug?)) 34 | (test-equal "parameterize" 35 | #t 36 | (begin 37 | (parameterize ((enable-debug? 1)) 38 | (enable-debug?))))) 39 | -------------------------------------------------------------------------------- /tests/keymap.scm: -------------------------------------------------------------------------------- 1 | (define-module (tests keymap) 2 | #:use-module (oop goops) 3 | #:use-module (srfi srfi-64) 4 | #:use-module (gwwm keymap)) 5 | 6 | (define SHIFT 1 ) 7 | (define CAPS 2) 8 | (define CTRL 3) 9 | (define ALT 4) 10 | (define MOD2 5) 11 | (define MOD3 6) 12 | (define LOGO 7) 13 | (define MOD5 8) 14 | 15 | (define (%modify-keys) 16 | (@@ (gwwm keymap) %modify-keys)) 17 | (test-group "keymap" 18 | (test-assert "define-modify-key" 19 | (begin (define-modify-key 'C CTRL) 20 | (equal? (hash-ref (%modify-keys) 'C) CTRL))) 21 | (define-modify-key 's LOGO) 22 | (define-modify-key 'S SHIFT) 23 | (define-modify-key 'M ALT) 24 | (test-equal "kbd*: simple key" 25 | (kbd* `(C h)) 26 | (list (make #:m `(C) #:k 'h))) 27 | (test-equal "kbd*: multi key" 28 | (kbd* `(C h) `(C f)) 29 | (list (make #:m `(C) #:k 'h) 30 | (make #:m `(C) #:k 'f))) 31 | (test-equal "kbd: simple key" 32 | (kbd (C h)) 33 | (kbd* `(C h))) 34 | (test-equal "kbd: multi key" 35 | (kbd (C h) (C x)) 36 | (kbd* `(C h) `(C x)))) 37 | -------------------------------------------------------------------------------- /tests/utils.scm: -------------------------------------------------------------------------------- 1 | (define-module (tests utils) 2 | #:use-module (oop goops) 3 | #:use-module (srfi srfi-64) 4 | #:use-module (gwwm utils)) 5 | 6 | (test-group "environment variable" 7 | (test-equal "save-environment-excursion" 8 | (begin (setenv "gwwm_test_environment" "1") 9 | (save-environment-excursion (setenv "gwwm_test_environment" "0") ) 10 | (getenv "gwwm_test_environment")) 11 | (getenv "gwwm_test_environment")) 12 | (test-equal "getenv*: no fallback" 13 | "1" 14 | (with-env (("GWWM_TEST_GETENV_WITHOUT_FALLBACK" "1")) 15 | (getenv* "GWWM_TEST_GETENV_WITHOUT_FALLBACK"))) 16 | (test-equal "getenv*: have fallback" 17 | "fallback" 18 | (getenv* "GWWM_TEST_GETENV_WITH_FALLBACK" "fallback")) 19 | (let ((xdg-home "/xdg-config-home")) 20 | (test-equal "get-xdg-config-home" 21 | xdg-home 22 | (with-env (("XDG_CONFIG_HOME" xdg-home)) 23 | (get-xdg-config-home))))) 24 | 25 | (test-group "let-slots" 26 | (define-class () 27 | (one #:init-keyword #:one #:getter .one #:setter set-one!) 28 | (two #:init-keyword #:two #:getter .two #:setter set-two!)) 29 | (let* ((n (random 200)) 30 | (obj (make #:one n))) 31 | (test-equal "let-slots: one" 32 | n (let-slots obj (one) one)) 33 | (let ((n (random 200))) 34 | (test-equal "let-slots: change name" 35 | n (let-slots obj (one) (set! one n) one)) 36 | (test-equal "let-slots: get change name" 37 | n (let-slots obj ((one one2)) one2))) 38 | 39 | 40 | (let ((n (random 200))) 41 | (test-equal "let-slots: get change name" 42 | n (begin (let-slots obj ((one one2)) (set! one2 n) one2) 43 | (.one obj))) 44 | (test-error "let-slots: slot name is not variable" 45 | #t 46 | (let-slots obj ((one one2)) (set! one n) ))) 47 | 48 | (test-error "let-slots: unbound " 49 | #t 50 | (let-slots obj (two) two)) 51 | 52 | (define-method (set-one! (obj ) (var ) ) 53 | (if var 54 | (next-method) 55 | (error "no!"))) 56 | (test-error "let-slots: care method" #t (let-slots obj (one) (set! one #f))))) 57 | -------------------------------------------------------------------------------- /tests/utils/ref.scm: -------------------------------------------------------------------------------- 1 | (define-module (tests utils ref) 2 | #:use-module (oop goops) 3 | #:use-module (srfi srfi-64) 4 | #:use-module (gwwm utils ref)) 5 | 6 | (test-group "ref" 7 | (test-equal "ref: vector" 8 | 1 9 | (ref #(1 2) 0)) 10 | (test-equal "ref: string" 11 | #\r 12 | (ref "ref" 0)) 13 | (test-equal "ref: list" 14 | 1 15 | (ref (list 1) 0)) 16 | (test-equal "ref: pair" 17 | 'car 18 | (ref (cons 'car 'cdr) 0)) 19 | (test-equal "ref: pair: car" 20 | 'car 21 | (ref (cons 'car 'cdr) 'car)) 22 | (test-equal "ref: pair: cdr" 23 | 'cdr 24 | (ref (cons 'car 'cdr) 'cdr))) 25 | -------------------------------------------------------------------------------- /util.c: -------------------------------------------------------------------------------- 1 | /* See LICENSE.dwm file for copyright and license details. */ 2 | #include 3 | #include 4 | #include 5 | #include 6 | 7 | #include "util.h" 8 | 9 | void 10 | _send_log(const char *arg, ...) { 11 | va_list ap; 12 | SCM scm =scm_make_list(scm_from_int(0), SCM_UNSPECIFIED); 13 | char *para; 14 | char *para2; 15 | 16 | va_start(ap, arg); 17 | scm=scm_cons(REF("gwwm utils srfi-215",arg) ,scm); 18 | scm=scm_cons(scm_from_utf8_string(va_arg(ap, char *)),scm); 19 | while(1) { 20 | para=va_arg(ap, char *); 21 | if ( strcmp( para, "/0") == 0 ) 22 | break; 23 | para2=va_arg(ap, char *); 24 | scm=scm_cons2(scm_from_utf8_string(para2), 25 | scm_from_utf8_symbol(para), 26 | scm); 27 | } 28 | va_end(ap); 29 | scm_apply_0(REF("gwwm utils srfi-215","send-log"), scm_reverse(scm)) ; 30 | } 31 | -------------------------------------------------------------------------------- /util.h: -------------------------------------------------------------------------------- 1 | /* See LICENSE.dwm file for copyright and license details. */ 2 | #ifndef GWWM_UTIL_H 3 | #define GWWM_UTIL_H 4 | 5 | #include 6 | #include 7 | #include 8 | 9 | #define REF(A, B) (scm_c_public_ref(A, B)) 10 | #define REFP(A, B) (scm_c_private_ref(A, B)) 11 | #define FROM_P(P) (scm_from_pointer(P, NULL)) 12 | #define TO_P(P) (scm_to_pointer(P)) 13 | #define REF_CALL_0(M, N) (scm_call_0(REF(M, N))) 14 | #define REF_CALL_1(M, N, ARG1) (scm_call_1(REF(M, N), ARG1)) 15 | #define REF_CALL_2(M, N, ARG1, ARG2) (scm_call_2(REF(M, N), ARG1, ARG2)) 16 | #define REF_CALL_3(M, N, ARG1, ARG2, ARG3) \ 17 | (scm_call_3(REF(M, N), ARG1, ARG2, ARG3)) 18 | #define SCM_LOOKUP_REF(name) (scm_variable_ref(scm_c_lookup(name))) 19 | #define MAKE_P(i) (REF_CALL_1("system foreign", "make-pointer", i)) 20 | #define WRAP_WLR_BACKEND(p) \ 21 | (REF_CALL_1("wlroots backend", "wrap-wlr-backend", FROM_P(p))) 22 | #define UNWRAP_WLR_BACKEND(p) \ 23 | (TO_P(REF_CALL_1("wlroots backend", "unwrap-wlr-backend", p))) 24 | #define WRAP_WLR_INPUT_DEVICE(p) \ 25 | (REF_CALL_1("wlroots types input-device", "wrap-wlr-input-device", FROM_P(p))) 26 | #define UNWRAP_WLR_INPUT_DEVICE(p) \ 27 | ((struct wlr_input_device *)(TO_P(REF_CALL_1("wlroots types input-device", "unwrap-wlr-input-device", p)))) 28 | #define WRAP_WL_DISPLAY(p) \ 29 | (REF_CALL_1("wayland server display", "wrap-wl-display", FROM_P(p))) 30 | #define UNWRAP_WL_DISPLAY(p) \ 31 | (TO_P(REF_CALL_1("wayland server display", "unwrap-wl-display", p))) 32 | #define UNWRAP_WL_LISTENER(p) \ 33 | (TO_P(REF_CALL_1("wayland server listener", "unwrap-wl-listener", p))) 34 | #define WRAP_WL_LISTENER(p) \ 35 | (REF_CALL_1("wayland server listener", "wrap-wl-listener", FROM_P(p))) 36 | #define UNWRAP_WL_LIST(p) \ 37 | ((struct wl_list*)(TO_P(REF_CALL_1("wayland list", "unwrap-wl-list", p)))) 38 | #define WRAP_WL_LIST(p) \ 39 | (REF_CALL_1("wayland list", "wrap-wl-list", FROM_P(p))) 40 | #define UNWRAP_WL_SIGNAL(p) \ 41 | (TO_P(REF_CALL_1("wayland signal", "unwrap-wl-signal", p))) 42 | #define WRAP_WL_SIGNAL(p) \ 43 | (REF_CALL_1("wayland signal", "wrap-wl-signal", FROM_P(p))) 44 | #define WRAP_WLR_OUTPUT_LAYOUT(p) \ 45 | (REF_CALL_1("wlroots types output-layout", "wrap-wlr-output-layout", \ 46 | FROM_P(p))) 47 | #define UNWRAP_WLR_OUTPUT_LAYOUT(p) \ 48 | (TO_P(REF_CALL_1("wlroots types output-layout ", "unwrap-wlr-output-layout", \ 49 | p))) 50 | #define WRAP_WLR_OUTPUT_CONFIGURATION_V1(p) \ 51 | (REF_CALL_1("wlroots types output-management", "wrap-wlr-output-configuration-v1", \ 52 | FROM_P(p))) 53 | #define UNWRAP_WLR_OUTPUT_CONFIGURATION_V1(p) \ 54 | (TO_P(REF_CALL_1("wlroots types output-management ", "unwrap-wlr-output-configuration-v1", \ 55 | p))) 56 | #define WRAP_WLR_OUTPUT(p) \ 57 | (REF_CALL_1("wlroots types output", "wrap-wlr-output", FROM_P(p))) 58 | #define UNWRAP_WLR_OUTPUT(p) \ 59 | (struct wlr_output *)(TO_P( \ 60 | REF_CALL_1("wlroots types output ", "unwrap-wlr-output", p))) 61 | #define WRAP_WLR_CURSOR(p) \ 62 | (REF_CALL_1("wlroots types cursor", "wrap-wlr-cursor", FROM_P(p))) 63 | #define UNWRAP_WLR_CURSOR(p) \ 64 | (struct wlr_cursor *)(TO_P( \ 65 | REF_CALL_1("wlroots types cursor ", "unwrap-wlr-cursor", p))) 66 | #define WRAP_WLR_XCURSOR_MANAGER(p) \ 67 | (REF_CALL_1("wlroots types xcursor-manager", "wrap-wlr-xcursor-manager", FROM_P(p))) 68 | #define UNWRAP_WLR_XCURSOR_MANAGER(p) \ 69 | (struct wlr_xcursor_manager *)(TO_P( \ 70 | REF_CALL_1("wlroots types xcursor-manager ", "unwrap-wlr-xcursor-manager", p))) 71 | 72 | #define WRAP_WLR_XDG_SURFACE(p) \ 73 | (REF_CALL_1("wlroots types xdg-shell", "wrap-wlr-xdg-surface", FROM_P(p))) 74 | #define UNWRAP_WLR_XDG_SURFACE(p) \ 75 | ((struct wlr_xdg_surface *)TO_P(REF_CALL_1("wlroots types xdg-shell", "unwrap-wlr-xdg-surface", p))) 76 | #define WRAP_WLR_XDG_POPUP(p) \ 77 | (REF_CALL_1("wlroots types xdg-shell", "wrap-wlr-xdg-popup", FROM_P(p))) 78 | #define UNWRAP_WLR_XDG_POPUP(p) \ 79 | (TO_P(REF_CALL_1("wlroots types xdg-shell", "unwrap-wlr-xdg-popup", p))) 80 | 81 | #define WRAP_WLR_SEAT(p) \ 82 | (REF_CALL_1("wlroots types seat", "wrap-wlr-seat", FROM_P(p))) 83 | #define UNWRAP_WLR_SEAT(p) \ 84 | (TO_P(REF_CALL_1("wlroots types seat", "unwrap-wlr-seat", p))) 85 | #define WRAP_WLR_SCENE_NODE(p) \ 86 | (REF_CALL_1("wlroots types scene", "wrap-wlr-scene-node", FROM_P(p))) 87 | #define UNWRAP_WLR_SCENE_NODE(p) \ 88 | (TO_P(REF_CALL_1("wlroots types scene", "unwrap-wlr-scene-node", p))) 89 | #define WRAP_WLR_SCENE_OUTPUT(p) \ 90 | (REF_CALL_1("wlroots types scene", "wrap-wlr-scene-output", FROM_P(p))) 91 | #define UNWRAP_WLR_SCENE_OUTPUT(p) \ 92 | (TO_P(REF_CALL_1("wlroots types scene", "unwrap-wlr-scene-output", p))) 93 | #define WRAP_WLR_SCENE_RECT(p) \ 94 | (REF_CALL_1("wlroots types scene", "wrap-wlr-scene-rect", FROM_P(p))) 95 | #define UNWRAP_WLR_SCENE_RECT(p) \ 96 | (TO_P(REF_CALL_1("wlroots types scene", "unwrap-wlr-scene-rect", p))) 97 | #define WRAP_XDG_TOPLEVEL_SET_FULLSCREEN_EVENT(p) \ 98 | (REF_CALL_1("wlroots types xdg-shell", \ 99 | "wrap-wlr-xdg-toplevel-set-fullscreen-event",FROM_P(p))) 100 | #define WRAP_WLR_SCENE(p) \ 101 | (REF_CALL_1("wlroots types scene", "wrap-wlr-scene", FROM_P(p))) 102 | #define UNWRAP_WLR_SCENE(p) \ 103 | (TO_P(REF_CALL_1("wlroots types scene", "unwrap-wlr-scene", p))) 104 | 105 | #define WRAP_WLR_EVENT_POINTER_AXIS(p) \ 106 | (REF_CALL_1("wlroots types pointer", "wrap-wlr-event-pointer-axis", \ 107 | FROM_P(p))) 108 | #define UNWRAP_WLR_EVENT_POINTER_AXIS(p) \ 109 | (TO_P(REF_CALL_1("wlroots types pointer", "unwrap-wlr-event-pointer-axis", \ 110 | p))) 111 | #define WRAP_WLR_EVENT_POINTER_BUTTON(p) \ 112 | (REF_CALL_1("wlroots types pointer", "wrap-wlr-event-pointer-button", \ 113 | FROM_P(p))) 114 | #define UNWRAP_WLR_EVENT_POINTER_BUTTON(p) \ 115 | (TO_P(REF_CALL_1("wlroots types pointer", "unwrap-wlr-event-pointer-button", \ 116 | p))) 117 | #define WRAP_WLR_SEAT_REWUEST_SET_SELECTION_EVENT(p) \ 118 | (REF_CALL_1("wlroots types seat", \ 119 | "wrap-wlr-seat-request-set-selection-event", FROM_P(p))) 120 | #define UNWRAP_WLR_SEAT_REWUEST_SET_SELECTION_EVENT(p) \ 121 | (TO_P(REF_CALL_1("wlroots types seat", \ 122 | "unwrap-wlr-seat-request-set-selection-event", p))) 123 | 124 | #define WRAP_WLR_XWAYLAND_SURFACE(p) \ 125 | (REF_CALL_1("wlroots xwayland", "wrap-wlr-xwayland-surface", FROM_P(p))) 126 | #define UNWRAP_WLR_XWAYLAND_SURFACE(p) \ 127 | ((struct wlr_xwayland_surface *)(TO_P(REF_CALL_1("wlroots xwayland", "unwrap-wlr-xwayland-surface", p)))) 128 | #define WRAP_WLR_BOX(p) \ 129 | (REF_CALL_1("wlroots util box", "wrap-wlr-box", FROM_P(p))) 130 | #define UNWRAP_WLR_BOX(p) \ 131 | ((struct wlr_box*)(TO_P(REF_CALL_1("wlroots util box", "unwrap-wlr-box", p)))) 132 | #define WRAP_WLR_SURFACE(p) \ 133 | (REF_CALL_1("wlroots types compositor", "wrap-wlr-surface", FROM_P(p))) 134 | #define UNWRAP_WLR_SURFACE(p) \ 135 | (TO_P(REF_CALL_1("wlroots types compositor", "unwrap-wlr-surface", p))) 136 | 137 | #define WRAP_WLR_LAYER_SURFACE(p) \ 138 | (REF_CALL_1("wlroots types layer-shell", "wrap-wlr-layer-surface-v1", FROM_P(p))) 139 | #define UNWRAP_WLR_LAYER_SURFACE(p) \ 140 | (TO_P(REF_CALL_1("wlroots types layer-shell", "unwrap-wlr-layer-surface-v1", p))) 141 | 142 | #define WRAP_WLR_RENDERER(p) \ 143 | (REF_CALL_1("wlroots render renderer", "wrap-wlr-renderer", FROM_P(p))) 144 | #define UNWRAP_WLR_RENDERER(p) \ 145 | (TO_P(REF_CALL_1("wlroots render renderer", "unwrap-wlr-renderer", p))) 146 | #define WRAP_WLR_ALLOCATOR(p) \ 147 | (REF_CALL_1("wlroots render allocator", "wrap-wlr-allocator", FROM_P(p))) 148 | #define UNWRAP_WLR_ALLOCATOR(p) \ 149 | (TO_P(REF_CALL_1("wlroots render allocator", "unwrap-wlr-allocator", p))) 150 | #define WRAP_WLR_IDLE(p) \ 151 | (REF_CALL_1("wlroots types idle", "wrap-wlr-idle", FROM_P(p))) 152 | #define UNWRAP_WLR_IDLE(p) \ 153 | (TO_P(REF_CALL_1("wlroots types idle", "unwrap-wlr-idle", p))) 154 | #define WRAP_WLR_BUFFER(p) \ 155 | (REF_CALL_1("wlroots types buffer", "wrap-wlr-buffer", FROM_P(p))) 156 | #define UNWRAP_WLR_BUFFER(p) \ 157 | (TO_P(REF_CALL_1("wlroots types buffer", "unwrap-wlr-buffer", p))) 158 | #define WRAP_WLR_EVENT_KEYBOARD_KEY(p) \ 159 | (REF_CALL_1("wlroots types keyboard", "wrap-wlr-event-keyboard-key", \ 160 | FROM_P(p))) 161 | #define UNWRAP_WLR_EVENT_KEYBOARD_KEY(p) \ 162 | (TO_P(REF_CALL_1("wlroots types keyboard", "unwrap-wlr-event-keyboard-key", \ 163 | p))) 164 | #define LAYOUT_PROCEDURE(l) (REF_CALL_1("gwwm layout", "layout-procedure", l)) 165 | #define INNER_MONITOR_HASH_TABLE REFP("gwwm monitor", "%monitors") 166 | #define send_log(v, b, ...) _send_log(#v, b, ##__VA_ARGS__, "/0") 167 | #define PRINT_FUNCTION send_log(DEBUG, __FUNCTION__); 168 | #define GWWM_ASSERT_CLIENT_OR_FALSE(client, position) \ 169 | SCM_ASSERT((SCM_IS_A_P(client, REFP("gwwm client", "")) || \ 170 | scm_is_false(client)), \ 171 | client, position, FUNC_NAME) 172 | void _send_log(const char *arg, ...); 173 | #endif 174 | --------------------------------------------------------------------------------