From 8179c0025a44a769ab6ad2e5c0a58f545517280c Mon Sep 17 00:00:00 2001 From: Case Duckworth Date: Wed, 17 Jan 2024 00:24:11 -0600 Subject: Change organization and massively refactor --- lib/keys.sls | 252 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 252 insertions(+) create mode 100644 lib/keys.sls (limited to 'lib/keys.sls') diff --git a/lib/keys.sls b/lib/keys.sls new file mode 100644 index 0000000..3be0384 --- /dev/null +++ b/lib/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) +;; - - 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))) -- cgit 1.4.1-21-gabe81