Change organization and massively refactor v001

7 files changed, 985 insertions, 0 deletions

@@ -0,0 +1,3 @@
+(module (acdwm events) ()
+  (import scheme (chicken base) (chicken module))
+  (include-relative "events.sls"))
@@ -0,0 +1,83 @@
+;;; (acdwm events) --- event handlers
+
+(import (acdwm keys)
+        (acdwm xlib)
+        (acdwm util)
+        (srfi 1))
+
+(export make-drag drag? drag-type drag-event drag-window drag-attrs)
+(define-record drag type event window attrs)
+
+(define drag (make-parameter #f))
+(define drag-types '(move resize))
+
+(define-public (initialize-drag type event)
+  (assert (memq type drag-types))
+  (let ((win (and (buttonpress? event)
+                  (xevent-xbutton-subwindow event))))
+    (and win
+         (drag (make-drag type event win (get-window-attributes win))))))
+
+(define-public (cancel-drag)
+  (free-xevent (drag-event (drag)))
+  (free-xwindowattributes (drag-attrs (drag)))
+  (drag #f))
+
+(define-public (handle-events #!optional (dpy (get-display)))
+  (let loop ((this (get-next-event dpy)))
+    (dprint "handling a " (xevent-type-name (xevent-type this)))
+    (cond
+     ((keypress? this)
+      (handle-keypress this dpy)
+      (loop (get-next-event dpy)))
+     ((buttonpress? this)
+      (handle-buttonpress this)
+      (loop (get-next-event dpy)))
+     ((buttonrelease? this)
+      (handle-buttonrelease this)
+      (loop (get-next-event dpy)))
+     ((motionnotify? this)
+      (handle-motion this)
+      (loop (get-next-event dpy)))
+     ;; Make sure this is at the end!
+     (else
+      (loop (get-next-event dpy))))))
+
+;;; Handlers
+
+(define-public (handle-keypress event
+                                #!optional (dpy (get-display)))
+  (let ((binding (find-keybinding event)))
+    (dprint "handle-keypress: " binding)
+    (and binding ((keybind-proc binding) event dpy))))
+
+(define-public (handle-buttonpress event
+                                   #!optional (dpy (get-display)))
+  (let ((binding (find-mousebinding event)))
+    (dprint "handle-buttonpress: " binding)
+    (and binding ((mousebind-proc binding) event dpy))))
+
+(define-public (handle-buttonrelease event
+                                     #!optional (dpy (get-display)))
+  (dprint "handle-buttonrelease")
+  (cancel-drag))
+
+(define-public (handle-motion event
+                              #!optional (dpy (get-display)))
+  (dprint "handle-motion")
+  (when (drag)
+    (when (some? (drag-window (drag)))
+      (let ((xd (- (xevent-xbutton-x_root event)
+                   (xevent-xbutton-x_root (drag-event (drag)))))
+            (yd (- (xevent-xbutton-y_root event)
+                   (xevent-xbutton-y_root (drag-event (drag))))))
+        (let ((xnew (+ (xwindowattributes-x (drag-attrs (drag)))
+                       (if (eq? (drag-type (drag)) 'move) xd 0)))
+              (ynew (+ (xwindowattributes-y (drag-attrs (drag)))
+                       (if (eq? (drag-type (drag)) 'move) yd 0)))
+              (wnew (max 1 (+ (xwindowattributes-width (drag-attrs (drag)))
+                              (if (eq? (drag-type (drag)) 'resize) xd 0))))
+              (hnew (max 1 (+ (xwindowattributes-height (drag-attrs (drag)))
+                              (if (eq? (drag-type (drag)) 'resize) yd 0)))))
+          (dprint wnew "x" hnew "+" xnew "+" ynew)
+          (xmoveresizewindow dpy (drag-window (drag)) xnew ynew wnew hnew))))))
@@ -0,0 +1,3 @@
+(module (acdwm keys) ()
+  (import scheme (chicken base) (chicken module))
+  (include-relative "keys.sls"))
@@ -0,0 +1,252 @@
+;;; (acdwm keys) --- key (and button!) binding tools
+
+(import (chicken bitwise)
+        (chicken irregex)
+        (chicken memory)
+        (srfi 1)
+        (acdwm xlib)
+        (acdwm util))
+
+;;; Defining bindings
+
+(define-public bindings
+  (make-parameter '()))
+
+(export keybind keybind?
+        keybind-keycode keybind-modmask keybind-proc)
+(define-record keybind
+  (setter keycode)
+  (setter modmask)
+  (setter proc))
+
+(export mousebind mousebind?
+        mousebind-button mousebind-modmask mousebind-proc)
+(define-record mousebind
+  (setter button)
+  (setter modmask)
+  (setter proc))
+
+(define-public (bind kbd proc #!optional (dpy (get-display)))
+  ;;; Public interface for make-(keybind|mousebind).
+  (receive (key mods) (parse-bind-description kbd)
+    (print "binding " kbd " to " proc)
+    (let ((bind (if (<= 1 key 5)
+                    (make-mousebind key mods proc)
+                    (make-keybind (->keycode key dpy) mods proc))))
+      (bindings (cons bind (bindings)))
+      (print "bindings: " (bindings)))))
+
+(define-public (unbind kbd)
+  (receive (key mods) (parse-bind-description kbd)
+    #f                                  ; TODO
+    ))
+
+;;; Matching bindings
+
+(define-public (keybind-match? kb ev #!optional (dpy (get-display)))
+  (and (or (keypress? ev) (keyrelease? ev))
+       (keybind? kb)
+       (and (= (xevent-xkey-keycode ev) (keybind-keycode kb))
+            (= (clean-mask (xevent-xkey-state ev)) (keybind-modmask kb))
+            (procedure? (keybind-proc kb)))))
+
+(define-public (find-keybinding ev)
+  (find (lambda (b) (keybind-match? b ev)) (bindings)))
+
+(define-public (mousebind-match? mb ev #!optional (dpy (get-display)))
+  (and (or (buttonpress? ev) (buttonrelease? ev))
+       (mousebind? mb)
+       (and (= (xevent-xbutton-button ev) (mousebind-button mb))
+            (= (clean-mask (xevent-xbutton-state ev)) (mousebind-modmask mb))
+            (procedure? (mousebind-proc mb)))))
+
+(define-public (find-mousebinding ev)
+  (find (lambda (b) (mousebind-match? b ev)) (bindings)))
+
+;;; Numlock & Modkeys
+
+(define numlock
+  (make-parameter 0))
+
+(define-public (update-numlock-mask #!optional (dpy (get-display)))
+  (call-with-modifier-keymap
+   (lambda (mm)
+     (let ((max-key-per-mod (xmodifierkeymap-max_keypermod mm)))
+       (do ((i 0 (add1 i)))
+           ((= i 8))
+         (do ((k 0 (add1 k)))
+             ((= k max-key-per-mod))
+           (let ((r (pointer-u8-ref     ; a KeyBind is an unsigned char
+                     (pointer+ (xmodifierkeymap-modifiermap mm)
+                               (+ i (* max-key-per-mod k))))))
+             (when (= r (->keycode XK_NUM_LOCK))
+               (numlock (arithmetic-shift 1 i))))))))))
+
+(define-public (clean-mask mask)
+  (bitwise-and mask
+               (bitwise-not (bitwise-ior (numlock) LOCKMASK))
+               (bitwise-ior SHIFTMASK CONTROLMASK
+                            MOD1MASK MOD2MASK MOD3MASK MOD4MASK MOD5MASK)))
+
+;;; Grabbing input
+
+(define *mods
+  (begin (update-numlock-mask)
+         (list 0 LOCKMASK (numlock) (bitwise-ior (numlock) LOCKMASK))))
+
+(define (grab-key key #!optional (dpy (get-display)))
+  (when (keybind? key)
+;; XXX    (dprint "grabbing " )
+    (for-each (lambda (mod)
+                (xgrabkey dpy
+                          (keybind-keycode key)
+                          (bitwise-ior mod (keybind-modmask key))
+                          (get-root dpy)
+                          TRUE
+                          GRABMODEASYNC
+                          GRABMODEASYNC))
+              *mods)))
+
+(define (grab-button btn #!optional (dpy (get-display)))
+  (when (mousebind? btn)
+    (for-each (lambda (mod)
+                (xgrabbutton dpy
+                             (mousebind-button btn)
+                             (bitwise-ior mod (mousebind-modmask btn))
+                             (get-root dpy)
+                             TRUE
+                             (bitwise-ior BUTTONPRESSMASK
+                                          BUTTONRELEASEMASK
+                                          POINTERMOTIONMASK)
+                             GRABMODEASYNC
+                             GRABMODEASYNC
+                             NONE
+                             NONE))
+              *mods)))
+
+(define-public (grab-input #!optional
+                           (bindings (bindings))
+                           (dpy (get-display)))
+  (xungrabkey dpy ANYKEY ANYMODIFIER (get-root dpy))
+  (for-each grab-key (filter keybind? bindings))
+  (for-each grab-button (filter mousebind? bindings)))
+
+;;; Parsing keybind descriptions
+;; `bind' does Emacs-style binding descriptions in DESC.  That is, it accepts a
+;; string of the form MODS-KEY, where
+;; - MODS is one of C, S, M, 1, 2, 3, 4, 5 (M = 1) (case-insensitive)
+;; - KEY is one of
+;; - - mouse buttons b1, b2, b3, b4, b5 (case-insensitive)
+;; - - <D?XK_NAME> is passed through as a symbol
+;; - - otherwise it's figured out through the `keycaps' alist
+
+;; NOTE: parse-bind-description returns a KeySym
+(define-public (parse-bind-description desc)
+  (let* ((m (match-bind-desc desc))
+         (p (cond
+             ((not m) #f)
+             ((irregex-match-substring m 'btn) => parse-button-match)
+             ((irregex-match-substring m 'raw) => parse-raw-match)
+             ((irregex-match-substring m 'key) => parse-key-match)
+             (else #f))))
+    (if p
+        (values p (extract-modmask m))
+        (values #f #f))))
+
+(define (match-bind-desc desc)
+  (irregex-match '(: (? (=> mods (+ (or "C-" "S-" "M-"
+                                        "1-" "2-" "3-" "4-" "5-"))))
+                     (or
+                      (: (or #\B #\b) (=> btn ("12345")))
+                      (: #\< (=> raw (+ (or alnum #\_))) #\>)
+                      (=> key any)))
+                 desc))
+
+(define (extract-modmask match)
+  (let ((m (irregex-match-substring match 'mods)))
+    (irregex-fold "[CSM12345]-"
+                  (lambda (i n s)
+                    (bitwise-ior s (case (string-ref
+                                          (irregex-match-substring n) 0)
+                                     ((#\C #\c) CONTROLMASK)
+                                     ((#\S #\s) SHIFTMASK)
+                                     ((#\M #\m #\1) MOD1MASK)
+                                     ((#\2) MOD2MASK)
+                                     ((#\3) MOD3MASK)
+                                     ((#\4) MOD4MASK)
+                                     ((#\5) MOD5MASK))))
+                  0
+                  (or m ""))))
+
+(define (parse-button-match btn)
+  (string->number btn))
+
+(define (parse-raw-match raw)
+  (string->keysym (string-append (if (irregex-match? "^D?XK_.*" raw) ""
+                                     "XK_")
+                                 (string-upcase raw))))
+
+(define (char<= . cs)
+  (apply <= (map char->integer cs)))
+
+(define (parse-key-match key)
+  (let ((ch (string-ref key 0)))
+    (cond
+     ((char<= #\a ch #\z)
+      (string->keysym (string-append "XK_LC" (string (char-upcase ch)))))
+     ((char<= #\A ch #\Z)
+      (string->keysym (string-append "XK_" (string ch))))
+     ((alist-ref ch keycaps))
+     (else
+      (let ((ks (char->integer (xstringtokeysym key))))
+        (if (zero? ks) #f ks))))))
+
+(define (string->keysym str)
+  (symbol->keysym (string->symbol str)))
+
+(define (string-upcase str)
+  (list->string (map char-upcase (string->list str))))
+
+(define keycaps
+  `((#\` . #x60)                        ; y no XK_GRAVE
+    (#\1 . ,XK_1)
+    (#\2 . ,XK_2)
+    (#\3 . ,XK_3)
+    (#\4 . ,XK_4)
+    (#\5 . ,XK_5)
+    (#\6 . ,XK_6)
+    (#\7 . ,XK_7)
+    (#\8 . ,XK_8)
+    (#\9 . ,XK_9)
+    (#\0 . ,XK_0)
+    (#\- . ,XK_MINUS)
+    (#\= . ,XK_EQUAL)
+    (#\[ . ,XK_BRACKETLEFT)
+    (#\] . ,XK_BRACKETRIGHT)
+    (#\\ . ,XK_BACKSLASH)
+    (#\; . ,XK_SEMICOLON)
+    (#\' . #x27)                        ; y no XK_APOSTROPHE
+    (#\, . ,XK_COMMA)
+    (#\. . ,XK_PERIOD)
+    (#\/ . ,XK_SLASH)
+    (#\~ . ,XK_ASCIITILDE)
+    (#\! . ,XK_EXCLAM)
+    (#\@ . ,XK_AT)
+    (#\# . ,XK_NUMBERSIGN)
+    (#\$ . ,XK_DOLLAR)
+    (#\% . ,XK_PERCENT)
+    (#\^ . ,XK_ASCIICIRCUM)
+    (#\& . ,XK_AMPERSAND)
+    (#\* . ,XK_ASTERISK)
+    (#\( . ,XK_PARENLEFT)
+    (#\) . ,XK_PARENRIGHT)
+    (#\_ . ,XK_UNDERSCORE)
+    (#\+ . ,XK_PLUS)
+    (#\{ . ,XK_BRACELEFT)
+    (#\} . ,XK_BRACERIGHT)
+    (#\| . ,XK_BAR)
+    (#\: . ,XK_COLON)
+    (#\" . ,XK_QUOTEDBL)
+    (#\< . ,XK_LESS)
+    (#\> . ,XK_GREATER)
+    (#\? . ,XK_QUESTION)))
@@ -0,0 +1,33 @@
+(module (acdwm util) (
+                      define-public
+                      ignore
+                      DEBUG
+                      dprint
+                      )
+
+  (import scheme (chicken base)
+          (chicken port))
+
+  (define-syntax define-public
+    (syntax-rules ()
+      ((define-public (name . arg) forms ...)
+       (begin (export name)
+              (define (name . arg) forms ...)))
+      ((define-public (name args ...) forms ...)
+       (begin (export name)
+              (define (name args ...) forms ...)))
+      ((define-public name value)
+       (begin (export name)
+              (define name value)))))
+
+  (define (ignore . _) #f)
+
+  (define (eprint . xs)
+    (with-output-to-port (current-error-port)
+      (lambda () (apply print xs))))
+
+  (define DEBUG (make-parameter #f))
+
+  (define (dprint . xs)
+    (when (DEBUG)
+      (apply eprint xs))))
@@ -0,0 +1,4 @@
+(module (acdwm xlib) ()
+  (import scheme (chicken base) (chicken module))
+  (reexport xlib)
+  (include-relative "xlib.sls"))
@@ -0,0 +1,607 @@
+;;; (acdw xlib) --- xlib wrapper ... wrapper
+;; Rationale: the xlib egg is by its own admission pretty raw.  this library
+;; tries to cook it a little.
+
+(import xlib
+        (chicken bitwise)
+        (acdwm util))
+(import-for-syntax (acdwm util))
+
+(define *xdisplay
+  (make-parameter
+   (delay (xopendisplay #f))))
+
+(define-public (get-display)
+  (force (*xdisplay)))
+
+(define-public (get-screen #!optional (dpy (get-display)))
+  (xdefaultscreen dpy))
+
+(define-public (get-root #!optional (dpy (get-display)) scrn)
+  (dprint "getting root")
+  (xrootwindow dpy (or scrn (get-screen dpy))))
+
+;;; Constants
+
+(define-public TRUE 1)
+(define-public FALSE 0)
+
+;;; Working with X structures
+;; These functions wrap C functions with 'return pointers'
+
+(define-public (get-next-event #!optional (dpy (get-display)))
+  (let ((event (make-xevent)))
+    (xnextevent dpy event)
+    (dprint "get-next-event: " (xevent-type-name (xevent-type event)))
+    event))
+
+(define-public (get-next-masked-event mask #!optional (dpy (get-display)))
+  (let ((event (make-xevent)))
+    (xmaskevent dpy mask event)
+    event))
+
+(define-public (get-window-attributes win #!optional (dpy (get-display)))
+  (let ((attrs (make-xwindowattributes)))
+    (xgetwindowattributes dpy win attrs)
+    attrs))
+
+;; And these wrap C functions to make sure resources are freed
+
+(define-public (call-with-modifier-keymap proc #!optional (dpy (get-display)))
+  (let ((modmap (make-xmodifierkeymap)))
+    (dynamic-wind (lambda () (set! modmap (xgetmodifiermapping dpy)))
+                  (lambda () (proc modmap))
+                  (lambda () (free-xmodifierkeymap modmap)))))
+
+;;; Predicates
+
+(define-public (none? x)                ; this could be zero? ... but maybe
+  (= NONE x))                           ; it'll change!
+
+(define-public some?                    ; neologism
+  (complement none?))
+
+;; Events
+(define-syntax define-event-predicate
+  (syntax-rules ()
+    ((define-event-predicate predicate event)
+     (define-public (predicate ev*)
+       (= event (xevent-type ev*))))))
+
+(define-event-predicate buttonpress? BUTTONPRESS)
+(define-event-predicate buttonrelease? BUTTONRELEASE)
+(define-event-predicate circulatenotify? CIRCULATENOTIFY)
+(define-event-predicate clientmessage? CLIENTMESSAGE)
+(define-event-predicate colormapnotify? COLORMAPNOTIFY)
+(define-event-predicate createnotify? CREATENOTIFY)
+(define-event-predicate destroynotify? DESTROYNOTIFY)
+(define-event-predicate enternotify? ENTERNOTIFY)
+(define-event-predicate expose? EXPOSE)
+(define-event-predicate focuschangemask? FOCUSCHANGEMASK)
+(define-event-predicate graphicsexpose? GRAPHICSEXPOSE)
+(define-event-predicate gravitynotify? GRAVITYNOTIFY)
+(define-event-predicate keypress? KEYPRESS)
+(define-event-predicate keyrelease? KEYRELEASE)
+(define-event-predicate keymapnotify? KEYMAPNOTIFY)
+(define-event-predicate leavenotify? LEAVENOTIFY)
+(define-event-predicate mapnotify? MAPNOTIFY)
+(define-event-predicate maprequest? MAPREQUEST)
+(define-event-predicate mappingnotify? MAPPINGNOTIFY)
+(define-event-predicate motionnotify? MOTIONNOTIFY)
+(define-event-predicate propertynotify? PROPERTYNOTIFY)
+(define-event-predicate reparentnotify? REPARENTNOTIFY)
+(define-event-predicate resizerequest? RESIZEREQUEST)
+(define-event-predicate selectionclear? SELECTIONCLEAR)
+(define-event-predicate selectionnotify? SELECTIONNOTIFY)
+(define-event-predicate selectionrequest? SELECTIONREQUEST)
+(define-event-predicate substructureredirectmask? SUBSTRUCTUREREDIRECTMASK)
+(define-event-predicate unmapnotify? UNMAPNOTIFY)
+(define-event-predicate visibilitynotify? VISIBILITYNOTIFY)
+;; (define-event-predicate xconfigureevent? XCONFIGUREEVENT)
+;; (define-event-predicate xconfigurerequestevent? XCONFIGUREREQUESTEVENT)
+;; (define-event-predicate xdestroywindowevent? XDESTROYWINDOWEVENT)
+;; (define-event-predicate xfocusoutevent? XFOCUSOUTEVENT)
+;; (define-event-predicate xgravityevent? XGRAVITYEVENT)
+;; (define-event-predicate xmapevent? XMAPEVENT)
+;; (define-event-predicate xnoexposeevent? XNOEXPOSEEVENT)
+;; (define-event-predicate xreparentevent? XREPARENTEVENT)
+;; (define-event-predicate xunmapevent? XUNMAPEVENT)
+
+;;; Deconstructing the XEvent union type
+
+(define-syntax define-xevent->subevent
+  (er-macro-transformer
+   (lambda (x r c)
+     (define (string-append->symbol . ss)
+       (string->symbol (apply string-append ss)))
+     ;; (define-xevent->subevent name . props)
+     (let* ((name (symbol->string (cadr x)))
+            (evname (string-append name "event"))
+            (fnname (string-append->symbol "xevent->" name "event")))
+       `(,(r 'define-public) (,fnname ,(r 'xev))
+         (dprint ',fnname)
+         (,(r 'let) ((,(r 'out) (,(string-append->symbol "make-" evname))))
+          ,@(map (lambda (p)
+                   ;; set-<evname>-<prop>! out (xevent-<name>-prop xev)
+                   (let* ((pname (symbol->string p))
+                          (form
+                           `(,(string-append->symbol "set-" evname "-" pname "!")
+                             ,(r 'out)
+                             (,(string-append->symbol "xevent-" name "-" pname)
+                              ,(r 'xev)))))
+                     `(begin (dprint ',form)
+                             ,form)))
+                 (cddr x))
+          (,(r 'free-xevent) ,(r 'xev))
+          ,(r 'out)))))))
+
+
+(define-xevent->subevent xany
+  type display send_event serial type window)
+(define-xevent->subevent xkey
+  type serial send_event display window root subwindow time
+  x y x_root y_root state keycode same_screen)
+(define-xevent->subevent xbutton
+  type serial send_event display window root subwindow time
+  x y x_root y_root state button same_screen)
+(define-xevent->subevent xmotion
+  type serial send_event display window root subwindow time
+  x y x_root y_root state is_hint same_screen)
+(define-xevent->subevent xcrossing
+  type serial send_event display window root subwindow time
+  x y x_root y_root mode detail same_screen focus state)
+(define-xevent->subevent xexpose
+  type serial send_event display window x y width height count)
+(define-xevent->subevent xgraphicsexpose
+  type serial send_event display drawable x y width height
+  count major_code minor_code)
+(define-xevent->subevent xnoexpose
+  type serial send_event display drawable major_code minor_code)
+(define-xevent->subevent xvisibility
+  type serial send_event display window state)
+(define-xevent->subevent xcreatewindow
+  type serial send_event display parent window
+  x y width height border_width override_redirect)
+(define-xevent->subevent xdestroywindow
+  type serial send_event display event window)
+(define-xevent->subevent xunmap
+  type serial send_event display event window from_configure)
+(define-xevent->subevent xmap
+  type serial send_event display event window override_redirect)
+(define-xevent->subevent xmaprequest
+  type serial send_event display parent window)
+(define-xevent->subevent xreparent
+  type serial send_event display event window parent override_redirect)
+(define-xevent->subevent xconfigure
+  type serial send_event display event window
+  x y width height border_width above override_redirect)
+(define-xevent->subevent xgravity
+  type serial send_event display event window x y)
+(define-xevent->subevent xresizerequest
+  type serial send_event display window width height)
+(define-xevent->subevent xconfigurerequest
+  type serial send_event display parent window
+  x y width height border_width above detail value_mask)
+(define-xevent->subevent xcirculate
+  type serial send_event display event window place)
+(define-xevent->subevent xcirculaterequest
+  type serial send_event display parent window place)
+(define-xevent->subevent xproperty
+  type serial send_event display window atom time state)
+(define-xevent->subevent xselectionclear
+  type serial send_event display window selection time)
+(define-xevent->subevent xselectionrequest
+  type serial send_event display owner requestor selection
+  target property time)
+(define-xevent->subevent xselection
+  type serial send_event display requestor selection
+  target property time)
+(define-xevent->subevent xcolormap
+  type serial send_event display window colormap new state)
+(define-xevent->subevent xmapping
+  type serial send_event display window request first_keycode count)
+(define-xevent->subevent xerror
+  type display resourceid serial
+  error_code request_code minor_code)
+;; (define-xevent->subevent xfocuschange)
+#;(define-xevent->subevent xclient
+type serial send_event display window message_type format
+data-b data-s data-l)
+#;(define-xevent->subevent xkeymap
+type serial send_event display window key_vector)
+
+;;; Keysyms, keycodes, etc.
+
+(define (keysym->keycode ks #!optional (dpy (get-display)))
+  (char->integer (xkeysymtokeycode dpy ks)))
+
+(define-public (symbol->keysym xk_symbol)
+  ;;; XK_<NAME> => <the integer defined by XK_<NAME>>
+  (let ((ks (alist-ref xk_symbol keysyms)))
+    (and ks ks)))
+
+(define-public (->keycode keysym/xk_symbol #!optional (dpy (get-display)))
+  ;; Because it's all integers at the bottom, this function assumes that its
+  ;; argument denotes a Keysym.
+  (cond
+   ((number? keysym/xk_symbol)
+    (keysym->keycode keysym/xk_symbol))
+   ((symbol? keysym/xk_symbol)
+    (keysym->keycode (symbol->keysym keysym/xk_symbol)))
+   ((char? keysym/xk_symbol)            ; a weird situation but w/e
+    (char->integer keysym/xk_symbol))
+   (else #f)))
+
+(define keysyms
+  `((XK_BACKSPACE . ,XK_BACKSPACE)
+    (XK_0 . ,XK_0)
+    (XK_1 . ,XK_1)
+    (XK_2 . ,XK_2)
+    (XK_3 . ,XK_3)
+    (XK_4 . ,XK_4)
+    (XK_5 . ,XK_5)
+    (XK_6 . ,XK_6)
+    (XK_7 . ,XK_7)
+    (XK_8 . ,XK_8)
+    (XK_9 . ,XK_9)
+    (XK_A . ,XK_A)
+    (XK_AACUTE . ,XK_AACUTE)
+    (XK_ACIRCUMFLEX . ,XK_ACIRCUMFLEX)
+    (XK_ACUTE . ,XK_ACUTE)
+    (XK_ADIAERESIS . ,XK_ADIAERESIS)
+    (XK_AE . ,XK_AE)
+    (XK_AGRAVE . ,XK_AGRAVE)
+    (XK_ALT_L . ,XK_ALT_L)
+    (XK_ALT_R . ,XK_ALT_R)
+    (XK_AMPERSAND . ,XK_AMPERSAND)
+    (XK_ARING . ,XK_ARING)
+    (XK_ASCIICIRCUM . ,XK_ASCIICIRCUM)
+    (XK_ASCIITILDE . ,XK_ASCIITILDE)
+    (XK_ASTERISK . ,XK_ASTERISK)
+    (XK_AT . ,XK_AT)
+    (XK_ATILDE . ,XK_ATILDE)
+    (XK_B . ,XK_B)
+    (XK_BACKSLASH . ,XK_BACKSLASH)
+    (XK_BAR . ,XK_BAR)
+    (XK_BEGIN . ,XK_BEGIN)
+    (XK_BRACELEFT . ,XK_BRACELEFT)
+    (XK_BRACERIGHT . ,XK_BRACERIGHT)
+    (XK_BRACKETLEFT . ,XK_BRACKETLEFT)
+    (XK_BRACKETRIGHT . ,XK_BRACKETRIGHT)
+    (XK_BREAK . ,XK_BREAK)
+    (XK_BROKENBAR . ,XK_BROKENBAR)
+    (XK_C . ,XK_C)
+    (XK_CANCEL . ,XK_CANCEL)
+    (XK_CAPS_LOCK . ,XK_CAPS_LOCK)
+    (XK_CCEDILLA . ,XK_CCEDILLA)
+    (XK_CEDILLA . ,XK_CEDILLA)
+    (XK_CENT . ,XK_CENT)
+    (XK_CLEAR . ,XK_CLEAR)
+    (XK_COLON . ,XK_COLON)
+    (XK_COMMA . ,XK_COMMA)
+    (XK_CONTROL_L . ,XK_CONTROL_L)
+    (XK_CONTROL_R . ,XK_CONTROL_R)
+    (XK_COPYRIGHT . ,XK_COPYRIGHT)
+    (XK_CURRENCY . ,XK_CURRENCY)
+    (XK_D . ,XK_D)
+    (XK_DEGREE . ,XK_DEGREE)
+    (XK_DELETE . ,XK_DELETE)
+    (XK_DIAERESIS . ,XK_DIAERESIS)
+    (XK_DIVISION . ,XK_DIVISION)
+    (XK_DOLLAR . ,XK_DOLLAR)
+    (XK_DOWN . ,XK_DOWN)
+    (XK_E . ,XK_E)
+    (XK_EACUTE . ,XK_EACUTE)
+    (XK_ECIRCUMFLEX . ,XK_ECIRCUMFLEX)
+    (XK_EDIAERESIS . ,XK_EDIAERESIS)
+    (XK_EGRAVE . ,XK_EGRAVE)
+    (XK_END . ,XK_END)
+    (XK_EQUAL . ,XK_EQUAL)
+    (XK_ESCAPE . ,XK_ESCAPE)
+    (XK_ETH . ,XK_ETH)
+    (XK_EXCLAM . ,XK_EXCLAM)
+    (XK_EXCLAMDOWN . ,XK_EXCLAMDOWN)
+    (XK_EXECUTE . ,XK_EXECUTE)
+    (XK_F . ,XK_F)
+    (XK_F1 . ,XK_F1)
+    (XK_F10 . ,XK_F10)
+    (XK_F11 . ,XK_F11)
+    (XK_F12 . ,XK_F12)
+    (XK_F13 . ,XK_F13)
+    (XK_F14 . ,XK_F14)
+    (XK_F15 . ,XK_F15)
+    (XK_F16 . ,XK_F16)
+    (XK_F17 . ,XK_F17)
+    (XK_F18 . ,XK_F18)
+    (XK_F19 . ,XK_F19)
+    (XK_F2 . ,XK_F2)
+    (XK_F20 . ,XK_F20)
+    (XK_F21 . ,XK_F21)
+    (XK_F22 . ,XK_F22)
+    (XK_F23 . ,XK_F23)
+    (XK_F24 . ,XK_F24)
+    (XK_F25 . ,XK_F25)
+    (XK_F26 . ,XK_F26)
+    (XK_F27 . ,XK_F27)
+    (XK_F28 . ,XK_F28)
+    (XK_F29 . ,XK_F29)
+    (XK_F3 . ,XK_F3)
+    (XK_F30 . ,XK_F30)
+    (XK_F31 . ,XK_F31)
+    (XK_F32 . ,XK_F32)
+    (XK_F33 . ,XK_F33)
+    (XK_F34 . ,XK_F34)
+    (XK_F35 . ,XK_F35)
+    (XK_F4 . ,XK_F4)
+    (XK_F5 . ,XK_F5)
+    (XK_F6 . ,XK_F6)
+    (XK_F7 . ,XK_F7)
+    (XK_F8 . ,XK_F8)
+    (XK_F9 . ,XK_F9)
+    (XK_FIND . ,XK_FIND)
+    (XK_G . ,XK_G)
+    (XK_GREATER . ,XK_GREATER)
+    (XK_GUILLEMOTLEFT . ,XK_GUILLEMOTLEFT)
+    (XK_GUILLEMOTRIGHT . ,XK_GUILLEMOTRIGHT)
+    (XK_H . ,XK_H)
+    (XK_HELP . ,XK_HELP)
+    (XK_HOME . ,XK_HOME)
+    (XK_HYPER_L . ,XK_HYPER_L)
+    (XK_HYPER_R . ,XK_HYPER_R)
+    (XK_HYPHEN . ,XK_HYPHEN)
+    (XK_I . ,XK_I)
+    (XK_IACUTE . ,XK_IACUTE)
+    (XK_ICIRCUMFLEX . ,XK_ICIRCUMFLEX)
+    (XK_IDIAERESIS . ,XK_IDIAERESIS)
+    (XK_IGRAVE . ,XK_IGRAVE)
+    (XK_INSERT . ,XK_INSERT)
+    (XK_J . ,XK_J)
+    (XK_K . ,XK_K)
+    (XK_KANJI . ,XK_KANJI)
+    (XK_KP_0 . ,XK_KP_0)
+    (XK_KP_1 . ,XK_KP_1)
+    (XK_KP_2 . ,XK_KP_2)
+    (XK_KP_3 . ,XK_KP_3)
+    (XK_KP_4 . ,XK_KP_4)
+    (XK_KP_5 . ,XK_KP_5)
+    (XK_KP_6 . ,XK_KP_6)
+    (XK_KP_7 . ,XK_KP_7)
+    (XK_KP_8 . ,XK_KP_8)
+    (XK_KP_9 . ,XK_KP_9)
+    (XK_KP_ADD . ,XK_KP_ADD)
+    (XK_KP_DECIMAL . ,XK_KP_DECIMAL)
+    (XK_KP_DIVIDE . ,XK_KP_DIVIDE)
+    (XK_KP_ENTER . ,XK_KP_ENTER)
+    (XK_KP_EQUAL . ,XK_KP_EQUAL)
+    (XK_KP_F1 . ,XK_KP_F1)
+    (XK_KP_F2 . ,XK_KP_F2)
+    (XK_KP_F3 . ,XK_KP_F3)
+    (XK_KP_F4 . ,XK_KP_F4)
+    (XK_KP_MULTIPLY . ,XK_KP_MULTIPLY)
+    (XK_KP_SEPARATOR . ,XK_KP_SEPARATOR)
+    (XK_KP_SPACE . ,XK_KP_SPACE)
+    (XK_KP_SUBTRACT . ,XK_KP_SUBTRACT)
+    (XK_KP_TAB . ,XK_KP_TAB)
+    (XK_L . ,XK_L)
+    (XK_L1 . ,XK_L1)
+    (XK_L10 . ,XK_L10)
+    (XK_L2 . ,XK_L2)
+    (XK_L3 . ,XK_L3)
+    (XK_L4 . ,XK_L4)
+    (XK_L5 . ,XK_L5)
+    (XK_L6 . ,XK_L6)
+    (XK_L7 . ,XK_L7)
+    (XK_L8 . ,XK_L8)
+    (XK_L9 . ,XK_L9)
+    (XK_LCA . ,XK_LCA)
+    (XK_LCAACUTE . ,XK_LCAACUTE)
+    (XK_LCACIRCUMFLEX . ,XK_LCACIRCUMFLEX)
+    (XK_LCADIAERESIS . ,XK_LCADIAERESIS)
+    (XK_LCAE . ,XK_LCAE)
+    (XK_LCAGRAVE . ,XK_LCAGRAVE)
+    (XK_LCARING . ,XK_LCARING)
+    (XK_LCATILDE . ,XK_LCATILDE)
+    (XK_LCB . ,XK_LCB)
+    (XK_LCC . ,XK_LCC)
+    (XK_LCCCEDILLA . ,XK_LCCCEDILLA)
+    (XK_LCD . ,XK_LCD)
+    (XK_LCE . ,XK_LCE)
+    (XK_LCEACUTE . ,XK_LCEACUTE)
+    (XK_LCECIRCUMFLEX . ,XK_LCECIRCUMFLEX)
+    (XK_LCEDIAERESIS . ,XK_LCEDIAERESIS)
+    (XK_LCEGRAVE . ,XK_LCEGRAVE)
+    (XK_LCETH . ,XK_LCETH)
+    (XK_LCF . ,XK_LCF)
+    (XK_LCG . ,XK_LCG)
+    (XK_LCH . ,XK_LCH)
+    (XK_LCI . ,XK_LCI)
+    (XK_LCIACUTE . ,XK_LCIACUTE)
+    (XK_LCICIRCUMFLEX . ,XK_LCICIRCUMFLEX)
+    (XK_LCIDIAERESIS . ,XK_LCIDIAERESIS)
+    (XK_LCIGRAVE . ,XK_LCIGRAVE)
+    (XK_LCJ . ,XK_LCJ)
+    (XK_LCK . ,XK_LCK)
+    (XK_LCL . ,XK_LCL)
+    (XK_LCM . ,XK_LCM)
+    (XK_LCN . ,XK_LCN)
+    (XK_LCNTILDE . ,XK_LCNTILDE)
+    (XK_LCO . ,XK_LCO)
+    (XK_LCOACUTE . ,XK_LCOACUTE)
+    (XK_LCOCIRCUMFLEX . ,XK_LCOCIRCUMFLEX)
+    (XK_LCODIAERESIS . ,XK_LCODIAERESIS)
+    (XK_LCOGRAVE . ,XK_LCOGRAVE)
+    (XK_LCOTILDE . ,XK_LCOTILDE)
+    (XK_LCP . ,XK_LCP)
+    (XK_LCQ . ,XK_LCQ)
+    (XK_LCR . ,XK_LCR)
+    (XK_LCS . ,XK_LCS)
+    (XK_LCT . ,XK_LCT)
+    (XK_LCTHORN . ,XK_LCTHORN)
+    (XK_LCU . ,XK_LCU)
+    (XK_LCUACUTE . ,XK_LCUACUTE)
+    (XK_LCUCIRCUMFLEX . ,XK_LCUCIRCUMFLEX)
+    (XK_LCUDIAERESIS . ,XK_LCUDIAERESIS)
+    (XK_LCUGRAVE . ,XK_LCUGRAVE)
+    (XK_LCV . ,XK_LCV)
+    (XK_LCW . ,XK_LCW)
+    (XK_LCX . ,XK_LCX)
+    (XK_LCY . ,XK_LCY)
+    (XK_LCYACUTE . ,XK_LCYACUTE)
+    (XK_LCZ . ,XK_LCZ)
+    (XK_LEFT . ,XK_LEFT)
+    (XK_LESS . ,XK_LESS)
+    (XK_LINEFEED . ,XK_LINEFEED)
+    (XK_M . ,XK_M)
+    (XK_MACRON . ,XK_MACRON)
+    (XK_MASCULINE . ,XK_MASCULINE)
+    (XK_MENU . ,XK_MENU)
+    (XK_META_L . ,XK_META_L)
+    (XK_META_R . ,XK_META_R)
+    (XK_MINUS . ,XK_MINUS)
+    (XK_MODE_SWITCH . ,XK_MODE_SWITCH)
+    (XK_MU . ,XK_MU)
+    (XK_MULTIPLY . ,XK_MULTIPLY)
+    (XK_MULTI_KEY . ,XK_MULTI_KEY)
+    (XK_N . ,XK_N)
+    (XK_NEXT . ,XK_NEXT)
+    (XK_NOBREAKSPACE . ,XK_NOBREAKSPACE)
+    (XK_NOTSIGN . ,XK_NOTSIGN)
+    (XK_NTILDE . ,XK_NTILDE)
+    (XK_NUMBERSIGN . ,XK_NUMBERSIGN)
+    (XK_NUM_LOCK . ,XK_NUM_LOCK)
+    (XK_O . ,XK_O)
+    (XK_OACUTE . ,XK_OACUTE)
+    (XK_OCIRCUMFLEX . ,XK_OCIRCUMFLEX)
+    (XK_ODIAERESIS . ,XK_ODIAERESIS)
+    (XK_OGRAVE . ,XK_OGRAVE)
+    (XK_ONEHALF . ,XK_ONEHALF)
+    (XK_ONEQUARTER . ,XK_ONEQUARTER)
+    (XK_ONESUPERIOR . ,XK_ONESUPERIOR)
+    (XK_OOBLIQUE . ,XK_OOBLIQUE)
+    (XK_ORDFEMININE . ,XK_ORDFEMININE)
+    (XK_OSLASH . ,XK_OSLASH)
+    (XK_OTILDE . ,XK_OTILDE)
+    (XK_P . ,XK_P)
+    (XK_PARAGRAPH . ,XK_PARAGRAPH)
+    (XK_PARENLEFT . ,XK_PARENLEFT)
+    (XK_PARENRIGHT . ,XK_PARENRIGHT)
+    (XK_PAUSE . ,XK_PAUSE)
+    (XK_PERCENT . ,XK_PERCENT)
+    (XK_PERIOD . ,XK_PERIOD)
+    (XK_PERIODCENTERED . ,XK_PERIODCENTERED)
+    (XK_PLUS . ,XK_PLUS)
+    (XK_PLUSMINUS . ,XK_PLUSMINUS)
+    (XK_PRINT . ,XK_PRINT)
+    (XK_PRIOR . ,XK_PRIOR)
+    (XK_Q . ,XK_Q)
+    (XK_QUESTION . ,XK_QUESTION)
+    (XK_QUESTIONDOWN . ,XK_QUESTIONDOWN)
+    (XK_QUOTEDBL . ,XK_QUOTEDBL)
+    (XK_QUOTELEFT . ,XK_QUOTELEFT)
+    (XK_QUOTERIGHT . ,XK_QUOTERIGHT)
+    (XK_R . ,XK_R)
+    (XK_R1 . ,XK_R1)
+    (XK_R10 . ,XK_R10)
+    (XK_R11 . ,XK_R11)
+    (XK_R12 . ,XK_R12)
+    (XK_R13 . ,XK_R13)
+    (XK_R14 . ,XK_R14)
+    (XK_R15 . ,XK_R15)
+    (XK_R2 . ,XK_R2)
+    (XK_R3 . ,XK_R3)
+    (XK_R4 . ,XK_R4)
+    (XK_R5 . ,XK_R5)
+    (XK_R6 . ,XK_R6)
+    (XK_R7 . ,XK_R7)
+    (XK_R8 . ,XK_R8)
+    (XK_R9 . ,XK_R9)
+    (XK_REDO . ,XK_REDO)
+    (XK_REGISTERED . ,XK_REGISTERED)
+    (XK_RETURN . ,XK_RETURN)
+    (XK_RIGHT . ,XK_RIGHT)
+    (XK_S . ,XK_S)
+    (XK_SCRIPT_SWITCH . ,XK_SCRIPT_SWITCH)
+    (XK_SECTION . ,XK_SECTION)
+    (XK_SELECT . ,XK_SELECT)
+    (XK_SEMICOLON . ,XK_SEMICOLON)
+    (XK_SHIFT_L . ,XK_SHIFT_L)
+    (XK_SHIFT_LOCK . ,XK_SHIFT_LOCK)
+    (XK_SHIFT_R . ,XK_SHIFT_R)
+    (XK_SLASH . ,XK_SLASH)
+    (XK_SPACE . ,XK_SPACE)
+    (XK_SSHARP . ,XK_SSHARP)
+    (XK_STERLING . ,XK_STERLING)
+    (XK_SUPER_L . ,XK_SUPER_L)
+    (XK_SUPER_R . ,XK_SUPER_R)
+    (XK_T . ,XK_T)
+    (XK_TAB . ,XK_TAB)
+    (XK_THORN . ,XK_THORN)
+    (XK_THREEQUARTERS . ,XK_THREEQUARTERS)
+    (XK_THREESUPERIOR . ,XK_THREESUPERIOR)
+    (XK_TWOSUPERIOR . ,XK_TWOSUPERIOR)
+    (XK_U . ,XK_U)
+    (XK_UACUTE . ,XK_UACUTE)
+    (XK_UCIRCUMFLEX . ,XK_UCIRCUMFLEX)
+    (XK_UDIAERESIS . ,XK_UDIAERESIS)
+    (XK_UGRAVE . ,XK_UGRAVE)
+    (XK_UNDERSCORE . ,XK_UNDERSCORE)
+    (XK_UNDO . ,XK_UNDO)
+    (XK_UP . ,XK_UP)
+    (XK_V . ,XK_V)
+    (XK_W . ,XK_W)
+    (XK_X . ,XK_X)
+    (XK_Y . ,XK_Y)
+    (XK_YACUTE . ,XK_YACUTE)
+    (XK_YDIAERESIS . ,XK_YDIAERESIS)
+    (XK_YEN . ,XK_YEN)
+    (XK_Z . ,XK_Z)
+    (DXK_ACUTE_ACCENT . ,DXK_ACUTE_ACCENT)
+    (DXK_CEDILLA_ACCENT . ,DXK_CEDILLA_ACCENT)
+    (DXK_CIRCUMFLEX_ACCENT . ,DXK_CIRCUMFLEX_ACCENT)
+    (DXK_DIAERESIS . ,DXK_DIAERESIS)
+    (DXK_GRAVE_ACCENT . ,DXK_GRAVE_ACCENT)
+    (DXK_REMOVE . ,DXK_REMOVE)
+    (DXK_RING_ACCENT . ,DXK_RING_ACCENT)
+    (DXK_TILDE . ,DXK_TILDE)))
+
+;;; Debugging
+
+(define xevent-types
+  `((,KEYPRESS . KEYPRESS)
+    (,KEYRELEASE . KEYRELEASE)
+    (,BUTTONPRESS . BUTTONPRESS)
+    (,BUTTONRELEASE . BUTTONRELEASE)
+    (,MOTIONNOTIFY . MOTIONNOTIFY)
+    (,ENTERNOTIFY . ENTERNOTIFY)
+    (,LEAVENOTIFY . LEAVENOTIFY)
+    (,FOCUSIN . FOCUSIN)
+    (,FOCUSOUT . FOCUSOUT)
+    (,KEYMAPNOTIFY . KEYMAPNOTIFY)
+    (,EXPOSE . EXPOSE)
+    (,GRAPHICSEXPOSE . GRAPHICSEXPOSE)
+    (,NOEXPOSE . NOEXPOSE)
+    (,VISIBILITYNOTIFY . VISIBILITYNOTIFY)
+    (,CREATENOTIFY . CREATENOTIFY)
+    (,DESTROYNOTIFY . DESTROYNOTIFY)
+    (,UNMAPNOTIFY . UNMAPNOTIFY)
+    (,MAPNOTIFY . MAPNOTIFY)
+    (,MAPREQUEST . MAPREQUEST)
+    (,REPARENTNOTIFY . REPARENTNOTIFY)
+    (,CONFIGURENOTIFY . CONFIGURENOTIFY)
+    (,CONFIGUREREQUEST . CONFIGUREREQUEST)
+    (,GRAVITYNOTIFY . GRAVITYNOTIFY)
+    (,RESIZEREQUEST . RESIZEREQUEST)
+    (,CIRCULATENOTIFY . CIRCULATENOTIFY)
+    (,CIRCULATEREQUEST . CIRCULATEREQUEST)
+    (,PROPERTYNOTIFY . PROPERTYNOTIFY)
+    (,SELECTIONCLEAR . SELECTIONCLEAR)
+    (,SELECTIONREQUEST . SELECTIONREQUEST)
+    (,SELECTIONNOTIFY . SELECTIONNOTIFY)
+    (,COLORMAPNOTIFY . COLORMAPNOTIFY)
+    (,CLIENTMESSAGE . CLIENTMESSAGE)
+    (,MAPPINGNOTIFY . MAPPINGNOTIFY)
+    #;(,GENERICEVENT . GENERICEVENT)))
+
+(define-public (xevent-type-name type)
+  (let ((x (assq type xevent-types)))
+    (and x (cdr x))))