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 *current-kmap* *current-event* 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       (message "~{~a ~}is undefined" (mapcar 'print-key (cons *current-event* (this-command-keys)))))))
 103
 104 (defgeneric handle-key-binding (binding key-seq))
 105
 106 (defmethod handle-key-binding ((binding keymap) key-seq)
 107   (let ((*current-kmap* binding))
 108     (push key-seq *this-command-keys*)
 109     ;;(message "~{~a ~}" (mapcar 'print-key (this-command-keys)))
 110     (next-event)))
 111
 112 (defmethod handle-key-binding ((binding symbol) key-seq)
 113   ;; reset the current-kmap in case the command reads input. XXX: Is
 114   ;; this hacky?
 115   (let ((*current-kmap* nil))
 116     ;; TODO: handle gathering args
 117     (push key-seq *this-command-keys*)
 118     (dispatch-command binding)))
 119
 120 ;; XXX: this is temporary
 121 (defconstant +key-backspace+ 0407)
 122 (defconstant +key-enter+ 0527)
 123 (defconstant +key-tab+ 0407)
 124 (defconstant +key-escape+ 27)
 125
 126 (defun wait-for-event ()
 127   ;; don't let the user C-g when reading for input
 128   (let ((*waiting-for-input* t))
 129     (loop
 130        for event = (frame-read-event (selected-frame))
 131        for procs = (poll-processes) do
 132        ;; they hit the interrupt key so simulate that key press
 133        (when *quit-flag*
 134          (setf *quit-flag* nil
 135                event (make-key
 136                       :char (code-char (+ *quit-code* 96))
 137                       :control t)))
 138        (cond (event
 139               (return event))
 140              ;; handle subprocesses
 141              (procs
 142               ;; let the user break out of this stuff
 143               (let ((*waiting-for-input* nil))
 144                 (dispatch-processes procs)
 145                 (frame-render (selected-frame))))
 146              (t
 147               ;; FIXME: Yes, I'd love to be able to sleep until there was
 148               ;; activity on one of the streams lice is waiting for input on
 149               ;; but i don't know how to do that. So just sleep for a tiny
 150               ;; bit to pass control over to the operating system and then
 151               ;; check again.
 152               (sleep 0.01))))))
 153
 154
 155 (defun top-level-next-event ()
 156   ;; Bind this locally so its value is restored after the
 157   ;; command is dispatched. Otherwise, calls to set-buffer
 158   ;; would stick.
 159   (setf *current-buffer* (window-buffer (frame-selected-window (selected-frame))))
 160   (next-event))
 161
 162 (provide :lice-0.1/input)