keymap.lisp

   1 ;;; keymaps for lice
   2
   3 (in-package "LICE")
   4
   5 (defstruct key char control meta alt shift hyper super)
   6 ;; (defclass key ()
   7 ;;   ((char :type character :initarg :char :reader key-char)
   8 ;;    (control :type boolean :initform nil :initarg :control :reader key-control)
   9 ;;    (meta :type boolean :initform nil :initarg :meta :reader key-meta)
  10 ;;    (alt :type boolean :initform nil :initarg :alt :reader key-alt)
  11 ;;    (shift :type boolean :initform nil :initarg :shift :reader key-shift)
  12 ;;    (hyper :type boolean :initform nil :initarg :hyper :reader key-hyper)
  13 ;;    (super :type boolean :initform nil :initarg :super :reader key-super))
  14 ;;   (:documentation "A key event."))
  15
  16 (defun print-mods (key)
  17   (concatenate 'string
  18                (when (key-control key) "C-")
  19                (when (key-meta key) "M-")
  20                (when (key-alt key) "A-")
  21                (when (key-shift key) "S-")
  22                (when (key-super key) "s-")
  23                (when (key-hyper key) "H-")))
  24
  25 (defun print-key (key)
  26   (format nil "~a~a" (print-mods key) (or (char-name (key-char key)) (key-char key))))
  27
  28 (defmethod print-object ((obj key) stream)
  29   (print-unreadable-object (obj stream :type t :identity t)
  30     (format stream "~s" (print-key obj))))
  31
  32 ;; ;; XXX: This is hacky. Convert the class into a sequence. Maybe we should
  33 ;; ;; use defstruct then?
  34 ;; (defun key-hashid (event)
  35 ;;   (typecase event
  36 ;;     (key (list (key-char event)
  37 ;;             (key-control event)
  38 ;;             (key-meta event)
  39 ;;             (key-alt event)
  40 ;;             (key-hyper event)
  41 ;;             (key-super event)))
  42 ;;     (t t)))
  43
  44 (defvar *current-keymap-theme* :lice)
  45
  46 (defvar *overriding-terminal-local-map* nil
  47   "Per-terminal keymap that overrides all other local keymaps.
  48 If this variable is non-nil, it is used as a keymap instead of the
  49 buffer's local map, and the minor mode keymaps and text property keymaps.
  50 It also replaces `overriding-local-map'.
  51
  52 This variable is intended to let commands such as `universal-argument'
  53 set up a different keymap for reading the next command.")
  54
  55 (defvar *overriding-local-map* nil
  56   "Keymap that overrides all other local keymaps.
  57 If this variable is non-nil, it is used as a keymap--replacing the
  58 buffer's local map, the minor mode keymaps, and char property keymaps.")
  59
  60 (defclass keymap ()
  61   ((parent :initform nil :initarg :parent :accessor keymap-parent)
  62    (prompt :initform nil :initarg :prompt :accessor keymap-prompt)
  63    (themes :initform (make-hash-table) :accessor keymap-themes)))
  64
  65 (defun make-sparse-keymap (&optional prompt)
  66   "Construct and return a new sparse keymap.
  67 The optional arg STRING supplies a menu name for the keymap
  68 in case you use it as a menu with `x-popup-menu'."
  69   (make-instance 'keymap :prompt prompt))
  70
  71 (defun get-keymap-theme (keymap theme)
  72   (gethash theme (keymap-themes keymap)))
  73
  74 (defun get-keymap-theme-create (keymap theme)
  75   (or (get-keymap-theme keymap theme)
  76       (setf (gethash theme (keymap-themes keymap)) (make-hash-table :size 200 :test 'equalp))))
  77
  78 (defun define-key (keymap key def &optional (theme :lice))
  79   (let ((map (get-keymap-theme-create keymap theme)))
  80     (setf (gethash #|(key-hashid key)|# key map) def)))
  81
  82 (defun lookup-key-internal (keymap key accept-default theme norecurse)
  83   (let* ((map (get-keymap-theme keymap theme))
  84          ;; some maps may not have a hash table for the theme.
  85          (cmd (and map (gethash #|(key-hashid key)|# key map))))
  86     (or
  87      ;; if the binding is another keymap, then lookup the rest of the key sequence
  88      (cond
  89        ((and (keymapp cmd) (not norecurse))
  90         (lookup-key cmd (cdr key) accept-default theme))
  91        (t cmd))
  92      ;; check parent for binding
  93      (when (keymap-parent keymap)
  94        (lookup-key (keymap-parent keymap) key nil theme))
  95      (when accept-default
  96        (and map (gethash t map))))))
  97
  98 (defun lookup-key (keymap key &optional accept-default (theme :lice))
  99   "In keymap KEYMAP, look up key sequence KEY.  Return the definition.
 100 nil means undefined.  See doc of `define-key' for kinds of definitions.
 101
 102 Normally, `lookup-key' ignores bindings for t, which act as default
 103 bindings, used when nothing else in the keymap applies; this makes it
 104 usable as a general function for probing keymaps.  However, if the
 105 third optional argument ACCEPT-DEFAULT is non-nil, `lookup-key' will
 106 recognize the default bindings, just as `read-key-sequence' does."
 107   (check-type keymap keymap)
 108   (lookup-key-internal keymap key accept-default theme nil))
 109
 110 (defun keymapp (object)
 111   (typep object 'keymap))
 112
 113 (depricate set-keymap-parent (setf keymap-parent))
 114 (defun set-keymap-parent (keymap parent)
 115   "Modify keymap to set its parent map to parent.
 116 Return parent.  parent should be nil or another keymap."
 117   (setf (keymap-parent keymap) parent))
 118
 119 (defun make-keymap (&optional string)
 120   (declare (ignore string))
 121   (error 'unimplemented))
 122
 123 (defun map-keymap (function keymap &optional (theme :lice))
 124   "Call FUNCTION once for each event binding in KEYMAP.
 125 FUNCTION is called with two arguments: the event that is bound, and
 126 the definition it is bound to.  If the event is an integer, it may be
 127 a generic character (see Info node `(elisp)Splitting Characters'), and
 128 that means that all actual character events belonging to that generic
 129 character are bound to the definition.
 130
 131 If KEYMAP has a parent, the parent's bindings are included as well.
 132 This works recursively: if the parent has itself a parent, then the
 133 grandparent's bindings are also included and so on."
 134   (let ((map (get-keymap-theme keymap theme)))
 135     (maphash function map)
 136     (when (keymap-parent keymap)
 137       (map-keymap function (keymap-parent keymap) theme))))
 138
 139 (defvar *global-map* (make-sparse-keymap)
 140   "The top level global keymap.")
 141
 142 (defvar *ctl-x-4-map* (make-sparse-keymap)
 143   "The C-x 4 keymap.")
 144
 145 (defvar *ctl-x-map* (make-sparse-keymap)
 146   "The C-x keymap.")
 147
 148 (defvar *ctl-c-map* (make-sparse-keymap)
 149   "The C-c keymap.")
 150
 151 (defvar *ctl-h-map* (make-sparse-keymap)
 152   "The C-h keymap.")
 153
 154 (defvar *current-global-map* *global-map*)
 155
 156 (defvar *current-kmap* nil
 157   "The key map that the next key event will use to find a
 158 corresponding command.")
 159
 160 (defun make-ctrl-h-map ()
 161   (let ((kmap (make-sparse-keymap)))
 162     (define-key kmap (make-key :char #\f) 'describe-symbol)
 163     kmap))
 164
 165 (defun make-ctrl-x-4-map ()
 166   (let ((kmap (make-sparse-keymap)))
 167     (define-key kmap (make-key :char #\b) 'switch-to-buffer-other-window)
 168     kmap))
 169
 170 (defun make-ctrl-x-map (ctl-x-4-map)
 171   (let ((kmap (make-sparse-keymap)))
 172     (define-key kmap (make-key :char #\e :control t) 'eval-last-sexp)
 173     (define-key kmap (make-key :char #\b) 'switch-to-buffer)
 174     (define-key kmap (make-key :char #\c :control t) 'save-buffers-kill-emacs)
 175     (define-key kmap (make-key :char #\f :control t) 'find-file)
 176     (define-key kmap (make-key :char #\s :control t) 'save-buffer)
 177     (define-key kmap (make-key :char #\k) 'kill-buffer)
 178     (define-key kmap (make-key :char #\o) 'other-window)
 179     (define-key kmap (make-key :char #\1) 'delete-other-windows)
 180     (define-key kmap (make-key :char #\2) 'split-window-vertically)
 181     (define-key kmap (make-key :char #\3) 'split-window-horizontally)
 182     (define-key kmap (make-key :char #\x :control t) 'exchange-point-and-mark)
 183     (define-key kmap (make-key :char #\t :control t) 'transpose-lines)
 184     (define-key kmap (make-key :char #\4) ctl-x-4-map)
 185     kmap))
 186
 187 (defun make-ctrl-c-map ()
 188   (let ((kmap (make-sparse-keymap)))
 189     kmap))
 190
 191 (defun make-global-map (ctl-x-prefix ctl-c-prefix ctl-h-prefix)
 192   "Generate self-insert commands for all printable characters. And
 193 more."
 194   (let ((kmap (make-sparse-keymap)))
 195     (loop for i in '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9
 196                      #\a #\b #\c #\d #\e #\f #\g #\h #\i #\j
 197                      #\k #\l #\m #\n #\o #\p #\q #\r #\s #\t
 198                      #\u #\v #\w #\x #\y #\z
 199                      #\A #\B #\C #\D #\E #\F #\G #\H #\I #\J
 200                      #\K #\L #\M #\N #\O #\P #\Q #\R #\S #\T
 201                      #\U #\V #\W #\X #\Y #\Z
 202                      #\Space #\! #\" #\# #\$ #\% #\& #\' #\(
 203                      #\) #\* #\+ #\, #\- #\. #\/ #\: #\; #\<
 204                      #\= #\> #\? #\@ #\[ #\\ #\] #\^ #\_ #\`
 205                      #\| #\} #\~ #\{)
 206           do (define-key kmap (make-key :char i) 'self-insert-command))
 207     (define-key kmap (make-key :char #\Return) 'newline)
 208     (define-key kmap (make-key :char #\Newline) 'newline)
 209     (define-key kmap (make-key :char #\o :control t) 'open-line)
 210     (define-key kmap (make-key :char #\j :control t) 'newline)
 211     (define-key kmap (make-key :char #\m :control t) 'newline)
 212     (define-key kmap (make-key :char #\f :control t) 'forward-char)
 213     (define-key kmap (make-key :char #\f :meta t) 'forward-word)
 214     (define-key kmap (make-key :char #\f :control t :meta t) 'forward-sexp)
 215     (define-key kmap (make-key :char #\b :control t :meta t) 'backward-sexp)
 216     (define-key kmap (make-key :char #\n :control t) 'next-line)
 217     (define-key kmap (make-key :char #\p :control t) 'previous-line)
 218     (define-key kmap (make-key :char #\b :control t) 'backward-char)
 219     (define-key kmap (make-key :char #\b :meta t) 'backward-word)
 220     (define-key kmap (make-key :char #\d :control t) 'delete-char)
 221     (define-key kmap (make-key :char #\d :meta t) 'kill-word)
 222     (define-key kmap (make-key :char #\Rubout :meta t) 'backward-kill-word)
 223     (define-key kmap (make-key :char #\Rubout) 'delete-backward-char)
 224     (define-key kmap (make-key :char #\Delete) 'delete-backward-char)
 225     (define-key kmap (make-key :char #\t :meta t) 'transpose-words)
 226     (define-key kmap (make-key :char #\t :control t) 'transpose-chars)
 227     ;;(define-key kmap (make-key :char #\h :control t) 'delete-backward-char)
 228     (define-key kmap (make-key :char #\u :control t) 'universal-argument)
 229     (define-key kmap (make-key :char #\a :control t) 'beginning-of-line)
 230     (define-key kmap (make-key :char #\e :control t) 'end-of-line)
 231     (define-key kmap (make-key :char #\g :control t) 'keyboard-quit)
 232     (define-key kmap (make-key :char #\v :control t) 'scroll-up)
 233     (define-key kmap (make-key :char #\v :meta t) 'scroll-down)
 234     (define-key kmap (make-key :char #\k :control t) 'kill-line)
 235     (define-key kmap (make-key :char #\w :control t) 'kill-region)
 236     (define-key kmap (make-key :char #\y :control t) 'yank)
 237     (define-key kmap (make-key :char #\y :meta t) 'yank-pop)
 238     (define-key kmap (make-key :char #\w :meta t) 'kill-ring-save)
 239     (define-key kmap (make-key :char #\> :meta t) 'end-of-buffer)
 240     (define-key kmap (make-key :char #\< :meta t) 'beginning-of-buffer)
 241     (define-key kmap (make-key :char #\x :meta t) 'execute-extended-command)
 242     (define-key kmap (make-key :char #\: :meta t) 'eval-expression)
 243     (define-key kmap (make-key :char #\Space :control t) 'set-mark-command)
 244     (define-key kmap (make-key :char #\` :control t) 'set-mark-command)
 245     (define-key kmap (make-key :char #\! :meta t) 'shell-command)
 246     (define-key kmap (make-key :char #\Space :meta t) 'just-one-space)
 247     (define-key kmap (make-key :char #\\ :control t :meta t) 'indent-region)
 248     (define-key kmap (make-key :char #\a :control t :meta t) 'beginning-of-defun)
 249     (define-key kmap (make-key :char #\e :control t :meta t) 'end-of-defun)
 250     (define-key kmap (make-key :char #\_ :control t) 'undo)
 251     (define-key kmap (make-key :char #\/ :control t) 'undo)
 252     (define-key kmap (make-key :char #\x :control t) ctl-x-prefix)
 253     (define-key kmap (make-key :char #\c :control t) ctl-c-prefix)
 254     (define-key kmap (make-key :char #\h :control t) ctl-h-prefix)
 255     kmap))
 256
 257 (defun make-global-keymaps ()
 258   "Create the default global keymaps and store them in *global-kmap
 259 *ctl-x-map*, ..."
 260   (setf *ctl-x-4-map* (make-ctrl-x-4-map)
 261         *ctl-x-map* (make-ctrl-x-map *ctl-x-4-map*)
 262         *ctl-c-map* (make-ctrl-c-map)
 263         *ctl-h-map* (make-ctrl-h-map)
 264         *global-map* (make-global-map *ctl-x-map* *ctl-c-map* *ctl-h-map*)))
 265
 266 (defun copy-keymap (keymap)
 267   (declare (ignore keymap))
 268   (error 'unimplemented))
 269
 270 (defun command-remapping ()
 271   (error 'unimplemented))
 272
 273 (defun key-binding (key &optional accept-default no-remap)
 274   (declare (ignore key accept-default no-remap))
 275   (error 'unimplemented))
 276
 277 (defun local-key-binding ()
 278   (error 'unimplemented))
 279
 280 (defun global-key-binding ()
 281   (error 'unimplemented))
 282
 283 (defun minor-mode-key-binding ()
 284   (error 'unimplemented))
 285
 286 (defun define-prefix-command ()
 287   (error 'unimplemented))
 288
 289 (defun use-global-map (keymap)
 290   (check-type keymap keymap)
 291   (setf *current-global-map* keymap))
 292
 293 (defun use-local-map (keymap)
 294   "Select KEYMAP as the local keymap.
 295 If KEYMAP is nil, that means no local keymap.
 296
 297 LICE: a buffer's local map is really the major mode map. Except
 298 it might not be in the future."
 299   (check-type keymap keymap)
 300   (error 'unimplemented))
 301
 302 (defun current-local-map ()
 303   "Return current buffer's local keymap, or nil if it has none.
 304
 305 LICE: the local map in really the major mode map. Except it might
 306 not be in the future."
 307   (buffer-local-map (current-buffer)))
 308
 309 (defun current-global-map ()
 310   "Return the current global keymap."
 311   *current-global-map*)
 312
 313 (defun current-minor-mode-maps ()
 314   (error 'unimplemented))
 315
 316 (defun current-active-maps ()
 317   (error 'unimplemented))
 318
 319 (defun accessible-keymaps ()
 320   (error 'unimplemented))
 321
 322 (defun key-description ()
 323   (error 'unimplemented))
 324
 325 (defun describe-vector ()
 326   (error 'unimplemented))
 327
 328 (defun single-key-description ()
 329   (error 'unimplemented))
 330
 331 (defun text-char-description ()
 332   (error 'unimplemented))
 333
 334 (defun where-is-internal ()
 335   (error 'unimplemented))
 336
 337 (defun describe-buffer-bindings ()
 338   (error 'unimplemented))
 339
 340 (defun apropos-internal ()
 341   (error 'unimplemented))
 342