;;; (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)))