src/keyboard.lisp

   1 ;;; Handle input and key command dispatching
   2
   3 (in-package "LICE")
   4
   5 (defvar deactivate-mark nil
   6   "If an editing command sets this to t, deactivate the mark afterward.
   7 The command loop sets this to nil before each command,
   8 and tests the value when the command returns.
   9 Buffer modification stores t in this variable.")
  10
  11 (defvar help-event-list nil
  12   "List of input events to recognize as meaning Help.
  13 These work just like the value of `help-char' (see that).")
  14
  15 (define-condition quit (lice-condition)
  16   () (:documentation "A condition raised when the user aborted the
  17 operation (by pressing C-g, for instance)."))
  18
  19 (defvar *last-command* nil
  20   "The last command executed.")
  21
  22 (defvar *this-command* nil
  23   "The command that was executed. This is to the command being
  24 executed before it is executed. *last-command* will be set to this
  25 when the command finishes. The command can change this value if it
  26 wants to change what *last-command* will be set to. Used in the `yank'
  27 and `yank-pop' commands.")
  28
  29 ;; (defun collect-command-args (cmd)
  30 ;;   "Return a list of values (some collected from the user) to pass to the CMD function."
  31 ;;   (mapcar (lambda (arg)
  32 ;;          (funcall (gethash (second arg) *command-arg-type-hash*)))
  33 ;;        (command-args cmd)))
  34
  35 (defvar *this-command-keys* nil
  36   "The key sequence that invoked the current command.")
  37
  38 (defun this-command-keys ()
  39   "Return the key sequence that invoked this command.
  40 The value is a list of KEYs."
  41   *this-command-keys*)
  42
  43 ;; FIXME some of this should go in call-interactively
  44 (defun dispatch-command (name)
  45   (let* ((cmd (lookup-command name))
  46          ;; (args (collect-command-args cmd))
  47          (*this-command* (and cmd (command-name cmd)))
  48          (*current-prefix-arg* *prefix-arg*))
  49     (clear-minibuffer)
  50     (if cmd
  51         (progn
  52           (restart-case
  53               (handler-bind
  54                   ((quit
  55                     (lambda (c)
  56                       (if *debug-on-quit*
  57                           (signal c)
  58                           (invoke-restart 'abort-command))))
  59                    (lice-condition
  60                     (lambda (c)
  61                       (if *debug-on-error*
  62                           (signal c)
  63                           (invoke-restart 'just-print-error c))))
  64                    (error
  65                     (lambda (c)
  66                       (if *debug-on-error*
  67                           (signal c)
  68                           (invoke-restart 'just-print-error c)))))
  69                 (call-interactively cmd))
  70             (abort-command ()
  71               :report "Abort the command."
  72               (message "Quit"))
  73             (just-print-error (c)
  74               :report "Abort and print error."
  75               ;; we need a bell
  76               (message "~a" c)))
  77           (setf *last-command* *this-command*)
  78           ;; handle undo
  79           (undo-boundary))
  80         ;; blink
  81         (message "Symbol's command is void: ~a" name))
  82     ;; reset command keys, since the command is over.
  83     *this-command-keys* nil))
  84
  85 ;;; events
  86
  87 (defvar *unread-command-events* nil
  88   "List of events to be read as the command input.
  89 These events are processed first, before actual keyboard input.")
  90
  91 (defun last-command-char ()
  92   "Return the character of the last key event in the list of key
  93 events that invoked the current command."
  94   (key-char (car *this-command-keys*)))
  95
  96 ;; This is really TTY specific
  97 (defun next-event ()
  98   (let* ((*current-event* (if *unread-command-events*
  99                               (pop *unread-command-events*)
 100                               (wait-for-event)))
 101          (def (if *current-kmap*
 102                   (lookup-key-internal *current-kmap* *current-event* t *current-keymap-theme* t nil t)
 103                   ;; no current kmap?
 104                   (or
 105                    (when *overriding-terminal-local-map*
 106                      (lookup-key-internal *overriding-terminal-local-map* *current-event* t *current-keymap-theme* t nil t))
 107                    (when *overriding-local-map*
 108                      (lookup-key-internal *overriding-local-map* *current-event* t *current-keymap-theme* t nil t))
 109                    (when (current-local-map)
 110                      (lookup-key-internal (current-local-map) *current-event* t *current-keymap-theme* t nil t))
 111                    ;;(lookup-key-internal (major-mode-map (major-mode)) *current-event* t *current-keymap-theme* t)
 112                    ;; TODO: minor mode maps
 113                    ;; check the global map
 114                    (lookup-key-internal *global-map* *current-event* t *current-keymap-theme* t nil t)))))
 115     (dformat +debug-v+ "~a ~s ~a~%"
 116              def #|(key-hashid *current-event*)|# *current-event* (key-char *current-event*))
 117     (if def
 118         (handle-key-binding def *current-event*)
 119         (progn
 120           (message "~{~a ~}is undefined" (mapcar 'print-key (reverse (cons *current-event* (this-command-keys)))))
 121           (setf *this-command-keys* nil)
 122           (throw :unbound-key nil)))))
 123
 124 (defgeneric handle-key-binding (binding key-seq))
 125
 126 (defmethod handle-key-binding ((binding keymap) key-seq)
 127   (let ((*current-kmap* binding))
 128     (push key-seq *this-command-keys*)
 129     ;;(message "~{~a ~}" (mapcar 'print-key (this-command-keys)))
 130     (next-event)))
 131
 132 (defmethod handle-key-binding ((binding symbol) key-seq)
 133   ;; reset the current-kmap in case the command reads input. XXX: Is
 134   ;; this hacky?
 135   (let ((*current-kmap* nil))
 136     ;; TODO: handle gathering args
 137     (push key-seq *this-command-keys*)
 138     (dispatch-command binding)))
 139
 140 ;; XXX: this is temporary
 141 (defconstant +key-backspace+ 0407)
 142 (defconstant +key-enter+ 0527)
 143 (defconstant +key-tab+ 0407)
 144 (defconstant +key-escape+ 27)
 145
 146 (defun wait-for-event (&optional time)
 147   ;; don't let the user C-g when reading for input
 148   (let ((*waiting-for-input* t)
 149         (now (get-internal-real-time)))
 150     (loop
 151        for event = (frame-read-event (selected-frame))
 152        for procs = (poll-processes) do
 153        ;; they hit the interrupt key so simulate that key press
 154        (when *quit-flag*
 155          (setf *quit-flag* nil
 156                event (make-key
 157                       :char (code-char (+ *quit-code* 96))
 158                       :control t)))
 159        (cond (event
 160               (return event))
 161              ;; handle subprocesses
 162              (procs
 163               ;; let the user break out of this stuff
 164               (let ((*waiting-for-input* nil))
 165                 (dispatch-processes procs)
 166                 (frame-render (selected-frame))))
 167              (t
 168               ;; FIXME: Yes, I'd love to be able to sleep until there was
 169               ;; activity on one of the streams lice is waiting for input on
 170               ;; but i don't know how to do that. So just sleep for a tiny
 171               ;; bit to pass control over to the operating system and then
 172               ;; check again.
 173               (sleep 0.01)))
 174        ;; let the loop run once
 175        until (and time (>= (/ (- (get-internal-real-time) now)
 176                               internal-time-units-per-second)
 177                            time)))))
 178
 179 (defun command-loop ()
 180   (labels ((ensure-current-buffer ()
 181              ;; Make sure the current window's buffer is selected.
 182              (unless (eq *current-buffer* (window-buffer (selected-window)))
 183                (setf *current-buffer* (window-buffer (selected-window))))))
 184   (setf *prefix-arg* nil
 185         *last-prefix-arg* nil)
 186   (loop
 187      (ensure-current-buffer)
 188      (setf deactivate-mark nil)
 189
 190      (frame-render (selected-frame))
 191
 192      ;; execute command
 193      (catch :unbound-key
 194        (next-event))
 195      ;; A filter may have run while we were reading the input.
 196      (ensure-current-buffer)
 197
 198 ))
 199
 200 ;;; Key bindings
 201
 202 (define-key *global-map* "C-z" 'suspend-emacs)
 203 (define-key *ctl-x-map* "C-z" 'suspend-emacs)
 204 (define-key *global-map* "M-C-c" 'exit-recursive-edit)
 205 (define-key *global-map* "C-]" 'abort-recursive-edit)
 206 (define-key *global-map* "M-x" 'execute-extended-command)
 207
 208 (provide :lice-0.1/input)