keyboard.lisp

   1 ;;; Handle input and key command dispatching
   2
   3 (in-package "LICE")
   4
   5 (define-condition quit (lice-condition)
   6   () (:documentation "A condition raised when the user aborted the
   7 operation (by pressing C-g, for instance)."))
   8
   9 (defvar *last-command* nil
  10   "The last command executed.")
  11
  12 (defvar *this-command* nil
  13   "The command that was executed. This is to the command being
  14 executed before it is executed. *last-command* will be set to this
  15 when the command finishes. The command can change this value if it
  16 wants to change what *last-command* will be set to. Used in the `yank'
  17 and `yank-pop' commands.")
  18
  19 (defvar *current-prefix-arg* nil
  20   "The value of the prefix argument for this editing command.
  21 It may be a number, or the symbol `-' for just a minus sign as arg,
  22 or a list whose car is a number for just one or more C-u's
  23 or nil if no argument has been specified.
  24 This is what `(interactive \"P\")' returns.")
  25
  26 ;; (defun collect-command-args (cmd)
  27 ;;   "Return a list of values (some collected from the user) to pass to the CMD function."
  28 ;;   (mapcar (lambda (arg)
  29 ;;          (funcall (gethash (second arg) *command-arg-type-hash*)))
  30 ;;        (command-args cmd)))
  31
  32 (defvar *this-command-keys* nil
  33   "The key sequence that invoked the current command.")
  34
  35 (defun this-command-keys ()
  36   "Return the key sequence that invoked this command.
  37 The value is a list of KEYs."
  38   *this-command-keys*)
  39
  40 (defun dispatch-command (name)
  41   (let* ((cmd (lookup-command name))
  42          ;; (args (collect-command-args cmd))
  43          (*this-command* (command-name cmd))
  44          (*current-prefix-arg* *prefix-arg*))
  45     (clear-minibuffer)
  46     (handler-case (funcall (command-fn cmd))
  47       (quit (c)
  48         (declare (ignore c))
  49         ;; FIXME: debug-on-quit
  50         (message "Quit"))
  51       (lice-condition (c)
  52         (message "~a" c))
  53       ;;       (error (c)
  54       ;;        ;; FIXME: lice has no debugger yet, so use the lisp's
  55       ;;        ;; debugger.
  56       ;;        (if *debug-on-error*
  57       ;;            (error c)
  58       ;;          (message "~a" c)))
  59       )
  60     (setf *last-command* *this-command*
  61           ;; reset command keys, since the command is over.
  62           *this-command-keys* nil)
  63     ;; handle undo
  64     (undo-boundary)
  65
  66 ))
  67
  68 ;;; events
  69
  70 (defvar *unread-command-events* nil
  71   "List of events to be read as the command input.
  72 These events are processed first, before actual keyboard input.")
  73
  74 (defun last-command-char ()
  75   "Return the character of the last key event in the list of key
  76 events that invoked the current command."
  77   (key-char (car *this-command-keys*)))
  78
  79 ;; This is really TTY specific
  80 (defun next-event ()
  81   (let* ((*current-event* (if *unread-command-events*
  82                               (pop *unread-command-events*)
  83                               (wait-for-event)))
  84          (def (if *current-kmap*
  85                   (lookup-key-internal *current-kmap* *current-event* t *current-keymap-theme* t)
  86                   ;; no current kmap?
  87                   (or
  88                    (when *overriding-terminal-local-map*
  89                      (lookup-key-internal *overriding-terminal-local-map* *current-event* t *current-keymap-theme* t))
  90                    (when *overriding-local-map*
  91                      (lookup-key-internal *overriding-local-map* *current-event* t *current-keymap-theme* t))
  92                    (when (current-local-map)
  93                      (lookup-key-internal (current-local-map) *current-event* t *current-keymap-theme* t))
  94                    ;;(lookup-key-internal (major-mode-map (major-mode)) *current-event* t *current-keymap-theme* t)
  95                    ;; TODO: minor mode maps
  96                    ;; check the global map
  97                    (lookup-key-internal *global-map* *current-event* t *current-keymap-theme* t)))))
  98     (dformat +debug-v+ "~a ~s ~a~%"
  99              def #|(key-hashid *current-event*)|# *current-event* (key-char *current-event*))
 100     (if def
 101         (handle-key-binding def *current-event*)
 102         (progn
 103           (message "~{~a ~}is undefined" (mapcar 'print-key (reverse (cons *current-event* (this-command-keys)))))
 104           (setf *this-command-keys* nil)
 105           (throw :unbound-key nil)))))
 106
 107 (defgeneric handle-key-binding (binding key-seq))
 108
 109 (defmethod handle-key-binding ((binding keymap) key-seq)
 110   (let ((*current-kmap* binding))
 111     (push key-seq *this-command-keys*)
 112     ;;(message "~{~a ~}" (mapcar 'print-key (this-command-keys)))
 113     (next-event)))
 114
 115 (defmethod handle-key-binding ((binding symbol) key-seq)
 116   ;; reset the current-kmap in case the command reads input. XXX: Is
 117   ;; this hacky?
 118   (let ((*current-kmap* nil))
 119     ;; TODO: handle gathering args
 120     (push key-seq *this-command-keys*)
 121     (dispatch-command binding)))
 122
 123 ;; XXX: this is temporary
 124 (defconstant +key-backspace+ 0407)
 125 (defconstant +key-enter+ 0527)
 126 (defconstant +key-tab+ 0407)
 127 (defconstant +key-escape+ 27)
 128
 129 (defun wait-for-event ()
 130   ;; don't let the user C-g when reading for input
 131   (let ((*waiting-for-input* t))
 132     (loop
 133        for event = (frame-read-event (selected-frame))
 134        for procs = (poll-processes) do
 135        ;; they hit the interrupt key so simulate that key press
 136        (when *quit-flag*
 137          (setf *quit-flag* nil
 138                event (make-key
 139                       :char (code-char (+ *quit-code* 96))
 140                       :control t)))
 141        (cond (event
 142               (return event))
 143              ;; handle subprocesses
 144              (procs
 145               ;; let the user break out of this stuff
 146               (let ((*waiting-for-input* nil))
 147                 (dispatch-processes procs)
 148                 (frame-render (selected-frame))))
 149              (t
 150               ;; FIXME: Yes, I'd love to be able to sleep until there was
 151               ;; activity on one of the streams lice is waiting for input on
 152               ;; but i don't know how to do that. So just sleep for a tiny
 153               ;; bit to pass control over to the operating system and then
 154               ;; check again.
 155               (sleep 0.01))))))
 156
 157
 158 (defun top-level-next-event ()
 159   ;; Bind this locally so its value is restored after the
 160   ;; command is dispatched. Otherwise, calls to set-buffer
 161   ;; would stick.
 162   (setf *current-buffer* (window-buffer (frame-selected-window (selected-frame))))
 163   (catch :unbound-key
 164     (next-event)))
 165
 166 (provide :lice-0.1/input)