boxes/keymap/keymap.lisp

;;;; keymap.lisp

(in-package #:keymap)

(defvar *global-keymap*)

(defclass keymap ()
  ((parents :accessor parents :initarg :parents :initform '())
   (keybindings :accessor keybindings :initform (make-hash-table :test 'equalp))))

(defun make-keymap (&rest parents)
  (make-instance 'keymap :parents parents))

(defun binding (key &optional (keymap *global-keymap*))
  (check-type keymap keymap)
  (ensure-normalized-key key)
  (multiple-value-bind (binding present?) (gethash key (keybindings keymap))
    (if present?
        (values binding keymap)
        (dolist (parent (parents keymap) (values nil nil))
          (multiple-value-bind (binding source) (binding key parent)
            (when source
              (return (values binding source))))))))

(defun own-keys (&optional keymap *global-keymap*)
  (check-type keymap keymap)
  (loop for key being the hash-keys in (keybindings keymap)
     collect key))

(defun all-keys (&optional (keymap *global-keymap*))
  (check-type keymap keymap)
  (remove-duplicates (append (own-keys keymap)
			     (loop for parent in (parents keymap)
				append (all-keys parent)))
		     :test #'key=
		     :from-end t))

(defun key-source (key &optional (keymap *global-keymap*))
  (check-type keymap keymap)
  (ensure-normalized-key key)
  (nth-value 1 (binding key keymap)))

(defun key-bound-p (key &optional (keymap *global-keymap*))
  (check-type keymap keymap)
  (ensure-normalized-key key)
  (not (null (key-source key keymap))))

(defun ownp (key &optional (keymap *global-keymap*))
  (check-type keymap keymap)
  (ensure-normalized-key key)
  (nth-value 1 (gethash key (keybindings keymap))))

(defun inheritedp (key &optional (keymap *global-keymap*))
  (check-type keymap keymap)
  (ensure-normalized-key key)
  (and (key-bound-p key keymap)
       (not (ownp key keymap))))

(defun activep (keymap)
  (check-type keymap keymap)
  (labels ((check (k)
	     (or (eql k keymap)
		 (some #'check (parents k)))))
    (check *global-keymap*)))

(defun install-keybinding (key binding)
  (if (null binding)
      (global-keymap:remove-binding key)
      (global-keymap:add-binding key binding)))

(defun install (keymap)
  (check-type keymap keymap)
  (global-keymap:clear :sync nil)
  (loop for key in (all-keys keymap)
     for binding = (binding key keymap)
     when binding
     do (global-keymap:add-binding key binding :sync nil))
  (global-keymap:sync)
  (setf *global-keymap* keymap))

(defun add-binding (key binding &optional (keymap *global-keymap*))
  (check-type binding (or function null))
  (check-type keymap keymap)
  (ensure-normalized-key key)
  (setf (gethash key (keybindings keymap)) binding)
  ;; important: after update
  ;; if the key is not present in the global keymap, the keymap is necessarily inactive and we do nothing
  (when (eql (key-source key *global-keymap*) keymap)
    (install-keybinding key binding)))

(defun remove-binding (key &optional (keymap *global-keymap*))
  (ensure-normalized-key key)
  (check-type keymap keymap)
  (let ((old-global-binding (binding key *global-keymap*)))
    (remhash key (keybindings keymap))
    (let ((new-global-binding (binding key *global-keymap*)))
      (unless (eql old-global-binding new-global-binding)
	(install-keybinding key new-global-binding)))))