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