1 files changed, 252 insertions, 0 deletions

@@ -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)))