input.lisp

   1 ;;; Handle input and key command dispatching
   2
   3 (in-package :lice)
   4
   5 (defvar *debug-on-error* t
   6   "Non-nil means enter the debugger if an unhandled error is signaled.")
   7
   8 (defvar *debug-on-quit* nil
   9   "Non-nil means enter the debugger if quit is signaled (C-g, for example).")
  10
  11 (define-condition quit (lice-condition)
  12   () (:documentation "A condition raised when the user aborted the
  13 operation (by pressing C-g, for instance)."))
  14
  15 (defclass command ()
  16   ((name :type symbol :initarg :name :accessor command-name)
  17    (args :type list :initarg :args :accessor command-args)
  18    (fn :type function :initarg :fn :accessor command-fn)
  19    (doc :type (or null string) :initarg :doc :accessor command-doc))
  20   (:documentation "An interactive command."))
  21
  22 (defvar *commands* (make-hash-table)
  23   "A hash table of interactive commands")
  24
  25 (defmacro defcommand (name (&optional args &rest interactive-args) &body body)
  26   "Create an interactive command named NAME."
  27   (let ((tmp (gensym)))
  28     `(progn
  29        (defun ,name ,args
  30          ,@body)
  31        (setf (gethash ',name *commands*)
  32              (make-instance
  33               'command
  34               :name ',name
  35               :args ',interactive-args
  36               :doc ,(when (typep (first body) 'string) (first body))
  37               :fn (lambda ()
  38                     (let ((,tmp (list ,@(mapcar (lambda (a)
  39                                                   (if (listp a)
  40                                                       `(funcall (gethash ,(first a) *command-arg-type-hash*) ,@(cdr a))
  41                                                     `(funcall (gethash ,a *command-arg-type-hash*))))
  42                                                 interactive-args))))
  43                       ;; XXX: Is this a sick hack?  We need to reset the
  44                       ;; prefix-arg at the right time. After the command
  45                       ;; is executed we can't because the universal
  46                       ;; argument code sets the prefix-arg for the next
  47                       ;; command. The Right spot seems to be to reset it
  48                       ;; once a command is about to be executed, and
  49                       ;; after the prefix arg has been gathered to be
  50                       ;; used in the command. Which is right here.
  51                       (setf *prefix-arg* nil)
  52                       ;; Note that we use the actual function. If the
  53                       ;; function is redefined, the command will
  54                       ;; continue to be defined and will call the
  55                       ;; function declared above, not the redefined one.
  56                       (apply #',name ,tmp))))))))
  57
  58
  59 (defvar *last-command* nil
  60   "The last command executed.")
  61
  62 (defvar *this-command* nil
  63   "The command that was executed. This is to the command being
  64 executed before it is executed. *last-command* will be set to this
  65 when the command finishes. The command can change this value if it
  66 wants to change what *last-command* will be set to. Used in the `yank'
  67 and `yank-pop' commands.")
  68
  69 (defvar *prefix-arg* nil
  70   "The value of the prefix argument for the next editing command.
  71 It may be a number, or the symbol `-' for just a minus sign as arg,
  72 or a list whose car is a number for just one or more C-u's
  73 or nil if no argument has been specified.
  74
  75 You cannot examine this variable to find the argument for this command
  76 since it has been set to nil by the time you can look.
  77 Instead, you should use the variable `current-prefix-arg', although
  78 normally commands can get this prefix argument with (interactive \"P\").")
  79
  80 (defvar *current-prefix-arg* nil
  81   "The value of the prefix argument for this editing command.
  82 It may be a number, or the symbol `-' for just a minus sign as arg,
  83 or a list whose car is a number for just one or more C-u's
  84 or nil if no argument has been specified.
  85 This is what `(interactive \"P\")' returns.")
  86
  87 (defgeneric lookup-command (name)
  88   (:documentation "lookup the command named NAME."))
  89
  90 (defmethod lookup-command ((name symbol))
  91   (gethash name *commands*))
  92
  93 (defmethod lookup-command ((name string))
  94   ;; FIXME: this can fill the keyword package with lots of junk
  95   ;; symbols.
  96   (gethash (intern (string-upcase name) "KEYWORD") *commands*))
  97
  98 (defun call-command (name &rest args)
  99   "Use this command to call an interactive command from a lisp program."
 100   (let ((cmd (lookup-command name)))
 101     (apply (command-fn cmd) args)))
 102
 103 (defvar *command-arg-type-hash* (make-hash-table)
 104   "A hash table of symbols. each symbol is an interactive argument
 105 type whose value is a function that is called to gather input from the
 106 user (or somewhere else) and return the result. For instance,
 107 :BUFFER's value is read-buffer which prompts the user for a buffer and
 108 returns it.
 109
 110 This variable is here to allow modules to add new argument types easily.")
 111
 112 ;; (defun collect-command-args (cmd)
 113 ;;   "Return a list of values (some collected from the user) to pass to the CMD function."
 114 ;;   (mapcar (lambda (arg)
 115 ;;          (funcall (gethash (second arg) *command-arg-type-hash*)))
 116 ;;        (command-args cmd)))
 117
 118 (defvar *this-command-keys* nil
 119   "The key sequence that invoked the current command.")
 120
 121 (defun this-command-keys ()
 122   "Return the key sequence that invoked this command.
 123 The value is a list of KEYs."
 124   *this-command-keys*)
 125
 126 (defun dispatch-command (name)
 127   (let* ((cmd (lookup-command name))
 128          ;; (args (collect-command-args cmd))
 129          (*this-command* (command-name cmd))
 130          (*current-prefix-arg* *prefix-arg*)
 131          ;; Bind this locally so its value is restored after the
 132          ;; command is dispatched. Otherwise, calls to set-buffer
 133          ;; would stick.
 134          (*current-buffer* (window-buffer (frame-current-window (selected-frame)))))
 135     (clear-minibuffer)
 136     (handler-case (funcall (command-fn cmd))
 137       (quit (c)
 138         (declare (ignore c))
 139         ;; FIXME: debug-on-quit
 140         (message "Quit"))
 141       (lice-condition (c)
 142         (message "~a" c))
 143 ;;       (error (c)
 144 ;;      ;; FIXME: lice has no debugger yet, so use the lisp's
 145 ;;      ;; debugger.
 146 ;;      (if *debug-on-error*
 147 ;;          (error c)
 148 ;;        (message "~a" c)))
 149       )
 150     (setf *last-command* *this-command*
 151           ;; reset command keys, since the command is over.
 152           *this-command-keys* nil)))
 153
 154 ;;; events
 155
 156 (defclass key ()
 157   ((char :type character :initarg :char :reader key-char)
 158    (control :type boolean :initform nil :initarg :control :reader key-control)
 159    (meta :type boolean :initform nil :initarg :meta :reader key-meta)
 160    (alt :type boolean :initform nil :initarg :alt :reader key-alt)
 161    (shift :type boolean :initform nil :initarg :shift :reader key-shift)
 162    (hyper :type boolean :initform nil :initarg :hyper :reader key-hyper)
 163    (super :type boolean :initform nil :initarg :super :reader key-super))
 164   (:documentation "A key event."))
 165
 166 (defun print-mods (key)
 167   (concatenate 'string
 168                (when (key-control key) "C-")
 169                (when (key-meta key) "M-")
 170                (when (key-alt key) "A-")
 171                (when (key-shift key) "S-")
 172                (when (key-super key) "s-")
 173                (when (key-hyper key) "H-")))
 174
 175 (defun print-key (key)
 176   (format nil "~a~a" (print-mods key) (or (char-name (key-char key)) (key-char key))))
 177
 178 (defmethod print-object ((obj key) stream)
 179   (print-unreadable-object (obj stream :type t :identity t)
 180     (format stream "~s" (print-key obj))))
 181
 182 (defvar *current-event* nil
 183   "The current event being processed.")
 184
 185 (defvar *unread-command-events* nil
 186   "List of events to be read as the command input.
 187 These events are processed first, before actual keyboard input.")
 188
 189 ;; This is probably, maybe, temporary
 190 (deftype keymap () 'hash-table)
 191
 192 (defun make-sparse-keymap ()
 193   (make-hash-table :size 200 :test 'equal))
 194
 195 (defvar *overriding-terminal-local-map* nil
 196   "Per-terminal keymap that overrides all other local keymaps.
 197 If this variable is non-nil, it is used as a keymap instead of the
 198 buffer's local map, and the minor mode keymaps and text property keymaps.
 199 It also replaces `overriding-local-map'.
 200
 201 This variable is intended to let commands such as `universal-argument'
 202 set up a different keymap for reading the next command.")
 203
 204 (defvar *overriding-local-map* nil
 205   "Keymap that overrides all other local keymaps.
 206 If this variable is non-nil, it is used as a keymap--replacing the
 207 buffer's local map, the minor mode keymaps, and char property keymaps.")
 208
 209 (defvar *global-map* (make-sparse-keymap)
 210   "The top level global keymap.")
 211
 212 (defvar *ctl-x-4-map* (make-sparse-keymap)
 213   "The C-x 4 keymap.")
 214
 215 (defvar *ctl-x-map* (make-sparse-keymap)
 216   "The C-x keymap.")
 217
 218 (defvar *ctl-c-map* (make-sparse-keymap)
 219   "The C-c keymap.")
 220
 221 (defvar *ctl-h-map* (make-sparse-keymap)
 222   "The C-h keymap.")
 223
 224 (defvar *current-kmap* nil
 225   "The key map that the next key event will use to find a
 226 corresponding command.")
 227
 228 (defun last-command-char ()
 229   "Return the character of the last key event in the list of key
 230 events that invoked the current command."
 231   (key-char (car *this-command-keys*)))
 232
 233 (defgeneric handle-key-binding (binding key-seq))
 234
 235 (defmethod handle-key-binding ((binding hash-table) key-seq)
 236   (let ((*current-kmap* binding))
 237     (push key-seq *this-command-keys*)
 238     ;;(message "~{~a ~}" (mapcar 'print-key (this-command-keys)))
 239     (next-event)))
 240
 241 (defmethod handle-key-binding ((binding symbol) key-seq)
 242   ;; reset the current-kmap in case the command reads input. XXX: Is
 243   ;; this hacky?
 244   (let ((*current-kmap* nil))
 245     ;; TODO: handle gathering args
 246     (push key-seq *this-command-keys*)
 247     (dispatch-command binding)))
 248
 249 ;; XXX: This is hacky. Convert the class into a sequence. Maybe we should
 250 ;; use defstruct then?
 251 (defun key-hashid (event)
 252   (typecase event
 253     (key (list (key-char event)
 254                (key-control event)
 255                (key-meta event)
 256                (key-alt event)
 257                (key-hyper event)
 258                (key-super event)))
 259     (t t)))
 260
 261 (defun lookup-key (keymap key &optional accept-default)
 262   "In keymap KEYMAP, look up key sequence KEY.  Return the definition.
 263 nil means undefined.  See doc of `define-key' for kinds of definitions.
 264
 265 Normally, `lookup-key' ignores bindings for t, which act as default
 266 bindings, used when nothing else in the keymap applies; this makes it
 267 usable as a general function for probing keymaps.  However, if the
 268 third optional argument ACCEPT-DEFAULT is non-nil, `lookup-key' will
 269 recognize the default bindings, just as `read-key-sequence' does."
 270   (or (gethash (key-hashid key) keymap)
 271       (when accept-default
 272         (gethash t keymap))))
 273
 274 ;; XXX: this is temporary
 275 (defconstant +key-backspace+ 0407)
 276 (defconstant +key-enter+ 0527)
 277 (defconstant +key-tab+ 0407)
 278 (defconstant +key-escape+ 27)
 279
 280 ;; This is really TTY specific
 281 (defun next-event ()
 282   (let* ((*current-event* (if *unread-command-events*
 283                               (pop *unread-command-events*)
 284                             (frame-read-event (selected-frame))))
 285          (def (if *current-kmap*
 286                   (lookup-key *current-kmap* *current-event* t)
 287                 ;; no current kmap?
 288                 (or
 289                  (when *overriding-terminal-local-map*
 290                    (lookup-key *overriding-terminal-local-map* *current-event* t))
 291                  (when *overriding-local-map*
 292                    (lookup-key *overriding-local-map* *current-event* t))
 293                  (lookup-key (major-mode-map (buffer-major-mode (current-buffer))) *current-event* t)
 294                  ;; check the global map
 295                  (lookup-key *global-map* *current-event* t)))))
 296     (dformat +debug-v+ "~a ~s ~a~%"
 297              def (key-hashid *current-event*) (key-char *current-event*))
 298     (if def
 299         (handle-key-binding def *current-event*)
 300       (message "~{~a ~}is undefined" (mapcar 'print-key (cons *current-event* (this-command-keys)))))))
 301
 302 (defun define-key (keymap key def)
 303   (setf (gethash (key-hashid key) keymap) def))
 304
 305 (defun make-ctrl-h-map ()
 306   (let ((kmap (make-sparse-keymap)))
 307     (define-key kmap (make-instance 'key :char #\f) 'describe-symbol)
 308     kmap))
 309
 310 (defun make-ctrl-x-4-map ()
 311   (let ((kmap (make-sparse-keymap)))
 312     (define-key kmap (make-instance 'key :char #\b) 'switch-to-buffer-other-window)
 313     kmap))
 314
 315 (defun make-ctrl-x-map (ctl-x-4-map)
 316   (let ((kmap (make-sparse-keymap)))
 317     (define-key kmap (make-instance 'key :char #\e :control t) 'eval-last-sexp)
 318     (define-key kmap (make-instance 'key :char #\b) 'switch-to-buffer)
 319     (define-key kmap (make-instance 'key :char #\c :control t) 'save-buffers-kill-emacs)
 320     (define-key kmap (make-instance 'key :char #\f :control t) 'find-file)
 321     (define-key kmap (make-instance 'key :char #\s :control t) 'save-buffer)
 322     (define-key kmap (make-instance 'key :char #\k) 'kill-buffer)
 323     (define-key kmap (make-instance 'key :char #\o) 'other-window)
 324     (define-key kmap (make-instance 'key :char #\1) 'delete-other-windows)
 325     (define-key kmap (make-instance 'key :char #\2) 'split-window-vertically)
 326     (define-key kmap (make-instance 'key :char #\3) 'split-window-horizontally)
 327     (define-key kmap (make-instance 'key :char #\x :control t) 'exchange-point-and-mark)
 328     (define-key kmap (make-instance 'key :char #\t :control t) 'transpose-lines)
 329     (define-key kmap (make-instance 'key :char #\4) ctl-x-4-map)
 330     kmap))
 331
 332 (defun make-ctrl-c-map ()
 333   (let ((kmap (make-sparse-keymap)))
 334     kmap))
 335
 336 (defun make-global-map (ctl-x-prefix ctl-c-prefix ctl-h-prefix)
 337   "Generate self-insert commands for all printable characters. And
 338 more."
 339   (let ((kmap (make-sparse-keymap)))
 340     (loop for i in '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9
 341                      #\a #\b #\c #\d #\e #\f #\g #\h #\i #\j
 342                      #\k #\l #\m #\n #\o #\p #\q #\r #\s #\t
 343                      #\u #\v #\w #\x #\y #\z
 344                      #\A #\B #\C #\D #\E #\F #\G #\H #\I #\J
 345                      #\K #\L #\M #\N #\O #\P #\Q #\R #\S #\T
 346                      #\U #\V #\W #\X #\Y #\Z
 347                      #\Space #\! #\" #\# #\$ #\% #\& #\' #\(
 348                      #\) #\* #\+ #\, #\- #\. #\/ #\: #\; #\<
 349                      #\= #\> #\? #\@ #\[ #\\ #\] #\^ #\_ #\`
 350                      #\| #\} #\~ #\{)
 351           do (define-key kmap (make-instance 'key :char i) 'self-insert-command))
 352     (define-key kmap (make-instance 'key :char #\Return) 'newline)
 353     (define-key kmap (make-instance 'key :char #\Newline) 'newline)
 354     (define-key kmap (make-instance 'key :char #\o :control t) 'open-line)
 355     (define-key kmap (make-instance 'key :char #\j :control t) 'newline)
 356     (define-key kmap (make-instance 'key :char #\m :control t) 'newline)
 357     (define-key kmap (make-instance 'key :char #\f :control t) 'forward-char)
 358     (define-key kmap (make-instance 'key :char #\f :meta t) 'forward-word)
 359     (define-key kmap (make-instance 'key :char #\f :control t :meta t) 'forward-sexp)
 360     (define-key kmap (make-instance 'key :char #\b :control t :meta t) 'backward-sexp)
 361     (define-key kmap (make-instance 'key :char #\n :control t) 'next-line)
 362     (define-key kmap (make-instance 'key :char #\p :control t) 'previous-line)
 363     (define-key kmap (make-instance 'key :char #\b :control t) 'backward-char)
 364     (define-key kmap (make-instance 'key :char #\b :meta t) 'backward-word)
 365     (define-key kmap (make-instance 'key :char #\d :control t) 'delete-char)
 366     (define-key kmap (make-instance 'key :char #\d :meta t) 'kill-word)
 367     (define-key kmap (make-instance 'key :char #\Rubout :meta t) 'backward-kill-word)
 368     (define-key kmap (make-instance 'key :char #\Rubout) 'delete-backward-char)
 369     (define-key kmap (make-instance 'key :char #\Delete) 'delete-backward-char)
 370     (define-key kmap (make-instance 'key :char #\t :meta t) 'transpose-words)
 371     (define-key kmap (make-instance 'key :char #\t :control t) 'transpose-chars)
 372     ;;(define-key kmap (make-instance 'key :char #\h :control t) 'delete-backward-char)
 373     (define-key kmap (make-instance 'key :char #\u :control t) 'universal-argument)
 374     (define-key kmap (make-instance 'key :char #\a :control t) 'beginning-of-line)
 375     (define-key kmap (make-instance 'key :char #\e :control t) 'end-of-line)
 376     (define-key kmap (make-instance 'key :char #\g :control t) 'keyboard-quit)
 377     (define-key kmap (make-instance 'key :char #\v :control t) 'scroll-up)
 378     (define-key kmap (make-instance 'key :char #\v :meta t) 'scroll-down)
 379     (define-key kmap (make-instance 'key :char #\k :control t) 'kill-line)
 380     (define-key kmap (make-instance 'key :char #\w :control t) 'kill-region)
 381     (define-key kmap (make-instance 'key :char #\y :control t) 'yank)
 382     (define-key kmap (make-instance 'key :char #\y :meta t) 'yank-pop)
 383     (define-key kmap (make-instance 'key :char #\w :meta t) 'kill-ring-save)
 384     (define-key kmap (make-instance 'key :char #\> :meta t) 'end-of-buffer)
 385     (define-key kmap (make-instance 'key :char #\< :meta t) 'beginning-of-buffer)
 386     (define-key kmap (make-instance 'key :char #\x :meta t) 'execute-extended-command)
 387     (define-key kmap (make-instance 'key :char #\: :meta t) 'eval-expression)
 388     (define-key kmap (make-instance 'key :char #\Space :control t) 'set-mark-command)
 389     (define-key kmap (make-instance 'key :char #\` :control t) 'set-mark-command)
 390     (define-key kmap (make-instance 'key :char #\x :control t) ctl-x-prefix)
 391     (define-key kmap (make-instance 'key :char #\c :control t) ctl-c-prefix)
 392     (define-key kmap (make-instance 'key :char #\h :control t) ctl-h-prefix)
 393     kmap))
 394
 395 (defun make-global-keymaps ()
 396   "Create the default global keymaps and store them in *global-kmap
 397 *ctl-x-map*, ..."
 398   (setf *ctl-x-4-map* (make-ctrl-x-4-map)
 399         *ctl-x-map* (make-ctrl-x-map *ctl-x-4-map*)
 400         *ctl-c-map* (make-ctrl-c-map)
 401         *ctl-h-map* (make-ctrl-h-map)
 402         *global-map* (make-global-map *ctl-x-map* *ctl-c-map* *ctl-h-map*)))
 403
 404 (provide :lice-0.1/input)