boxes/keymap/global-keymap.lisp

;;;; global-keymap.lisp

(in-package #:global-keymap)

(defvar *keybindings*)

(defvar *keybinding-functions*)

(defvar *keybinding-counter*)

(defun init ()
  (setf *keybindings* (make-hash-table :test 'equalp)
	*keybinding-functions* (make-hash-table)
	*keybinding-counter* 0))

(init)

(defun sync ()
  (let ((m (stumpwm:make-sparse-keymap)))
    (loop for key being the hash-keys in *keybindings* using (hash-value code)
          do (stumpwm:define-key m key (format nil "call-thunk ~D" code)))
    (setf stumpwm:*top-map* m)
    (stumpwm::sync-keys)))

(defun install-key (key)
  (ensure-normalized-key key)
  (stumpwm:define-key stumpwm:*top-map* key (format nil "call-thunk ~D" (gethash key *keybindings*))))

(defun uninstall-key (key)
  (ensure-normalized-key key)
  (stumpwm:undefine-key stumpwm:*top-map* key))

(defun add-binding (key thunk &key (sync t))
  (multiple-value-bind (code binding-exists?) (gethash key *keybindings* (incf *keybinding-counter*))
    (unless binding-exists?
      (setf (gethash key *keybindings*) code))
    (setf (gethash code *keybinding-functions*) thunk))
  (when sync
    (install-key key)))

(defun remove-binding (key &key (sync t))
  (ensure-normalized-key key)
  (when sync
    (uninstall-key key))
  (remhash (gethash key *keybinding-functions*) *keybinding-functions*)
  (remhash key *keybinding-functions*))

(defun binding (key)
  (ensure-normalized-key key)
  (multiple-value-bind (code binding-exists?) (gethash key *keybindings*)
    (if binding-exists?
        (values (gethash code *keybinding-functions*))
        nil)))

(defun clear (&key (sync t))
  (init)
  (when sync
    (setf stumpwm:*top-map* (stumpwm:make-sparse-keymap))
    (stumpwm::sync-keys)))

(defun keys ()
  (loop for key being the hash-keys in *keybindings*
       collect key))

(stumpwm:defcommand call-thunk (code) ((:number code))
  (handler-case (funcall (gethash code *keybinding-functions*))
    (simple-error (c) (stumpwm:message "~A" c))
    (error () nil)))

(unexport 'call-thunk)