src/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     (restart-case
  47         (handler-bind
  48             ((quit
  49               (lambda (c)
  50                 (if *debug-on-quit*
  51                     (signal c)
  52                     (invoke-restart 'abort-command))))
  53              (lice-condition
  54               (lambda (c)
  55                 (if *debug-on-error*
  56                     (signal c)
  57                     (invoke-restart 'just-print-error c))))
  58              (error
  59               (lambda (c)
  60                 (if *debug-on-error*
  61                     (signal c)
  62                     (invoke-restart 'just-print-error c)))))
  63           (funcall (command-fn cmd)))
  64       (abort-command ()
  65         :report "Abort the command."
  66         (message "Quit"))
  67       (just-print-error (c)
  68         :report "Abort and print error."
  69         ;; we need a bell
  70         (message "~a" c)))
  71     (setf *last-command* *this-command*
  72           ;; reset command keys, since the command is over.
  73           *this-command-keys* nil)
  74     ;; handle undo
  75     (undo-boundary)))
  76
  77 ;;; events
  78
  79 (defvar *unread-command-events* nil
  80   "List of events to be read as the command input.
  81 These events are processed first, before actual keyboard input.")
  82
  83 (defun last-command-char ()
  84   "Return the character of the last key event in the list of key
  85 events that invoked the current command."
  86   (key-char (car *this-command-keys*)))
  87
  88 ;; This is really TTY specific
  89 (defun next-event ()
  90   (let* ((*current-event* (if *unread-command-events*
  91                               (pop *unread-command-events*)
  92                               (wait-for-event)))
  93          (def (if *current-kmap*
  94                   (lookup-key-internal *current-kmap* *current-event* t *current-keymap-theme* t)
  95                   ;; no current kmap?
  96                   (or
  97                    (when *overriding-terminal-local-map*
  98                      (lookup-key-internal *overriding-terminal-local-map* *current-event* t *current-keymap-theme* t))
  99                    (when *overriding-local-map*
 100                      (lookup-key-internal *overriding-local-map* *current-event* t *current-keymap-theme* t))
 101                    (when (current-local-map)
 102                      (lookup-key-internal (current-local-map) *current-event* t *current-keymap-theme* t))
 103                    ;;(lookup-key-internal (major-mode-map (major-mode)) *current-event* t *current-keymap-theme* t)
 104                    ;; TODO: minor mode maps
 105                    ;; check the global map
 106                    (lookup-key-internal *global-map* *current-event* t *current-keymap-theme* t)))))
 107     (dformat +debug-v+ "~a ~s ~a~%"
 108              def #|(key-hashid *current-event*)|# *current-event* (key-char *current-event*))
 109     (if def
 110         (handle-key-binding def *current-event*)
 111         (progn
 112           (message "~{~a ~}is undefined" (mapcar 'print-key (reverse (cons *current-event* (this-command-keys)))))
 113           (setf *this-command-keys* nil)
 114           (throw :unbound-key nil)))))
 115
 116 (defgeneric handle-key-binding (binding key-seq))
 117
 118 (defmethod handle-key-binding ((binding keymap) key-seq)
 119   (let ((*current-kmap* binding))
 120     (push key-seq *this-command-keys*)
 121     ;;(message "~{~a ~}" (mapcar 'print-key (this-command-keys)))
 122     (next-event)))
 123
 124 (defmethod handle-key-binding ((binding symbol) key-seq)
 125   ;; reset the current-kmap in case the command reads input. XXX: Is
 126   ;; this hacky?
 127   (let ((*current-kmap* nil))
 128     ;; TODO: handle gathering args
 129     (push key-seq *this-command-keys*)
 130     (dispatch-command binding)))
 131
 132 ;; XXX: this is temporary
 133 (defconstant +key-backspace+ 0407)
 134 (defconstant +key-enter+ 0527)
 135 (defconstant +key-tab+ 0407)
 136 (defconstant +key-escape+ 27)
 137
 138 (defun wait-for-event (&optional time)
 139   ;; don't let the user C-g when reading for input
 140   (let ((*waiting-for-input* t)
 141         (now (get-internal-real-time)))
 142     (loop
 143        for event = (frame-read-event (selected-frame))
 144        for procs = (poll-processes) do
 145        ;; they hit the interrupt key so simulate that key press
 146        (when *quit-flag*
 147          (setf *quit-flag* nil
 148                event (make-key
 149                       :char (code-char (+ *quit-code* 96))
 150                       :control t)))
 151        (cond (event
 152               (return event))
 153              ;; handle subprocesses
 154              (procs
 155               ;; let the user break out of this stuff
 156               (let ((*waiting-for-input* nil))
 157                 (dispatch-processes procs)
 158                 (frame-render (selected-frame))))
 159              (t
 160               ;; FIXME: Yes, I'd love to be able to sleep until there was
 161               ;; activity on one of the streams lice is waiting for input on
 162               ;; but i don't know how to do that. So just sleep for a tiny
 163               ;; bit to pass control over to the operating system and then
 164               ;; check again.
 165               (sleep 0.01)))
 166        ;; let the loop run once
 167        until (and time (>= (/ (- (get-internal-real-time) now)
 168                               internal-time-units-per-second)
 169                            time)))))
 170
 171
 172 (defun top-level-next-event ()
 173   ;; Bind this locally so its value is restored after the
 174   ;; command is dispatched. Otherwise, calls to set-buffer
 175   ;; would stick.
 176   (setf *current-buffer* (window-buffer (frame-selected-window (selected-frame))))
 177   (catch :unbound-key
 178     (next-event)))
 179
 180 (provide :lice-0.1/input)