src/keyboard.lisp

   1 ;;; Handle input and key command dispatching
   2
   3 (in-package "LICE")
   4
   5 (defvar help-event-list nil
   6   "List of input events to recognize as meaning Help.
   7 These work just like the value of `help-char' (see that).")
   8
   9 (define-condition quit (lice-condition)
  10   () (:documentation "A condition raised when the user aborted the
  11 operation (by pressing C-g, for instance)."))
  12
  13 (defvar *last-command* nil
  14   "The last command executed.")
  15
  16 (defvar *this-command* nil
  17   "The command that was executed. This is to the command being
  18 executed before it is executed. *last-command* will be set to this
  19 when the command finishes. The command can change this value if it
  20 wants to change what *last-command* will be set to. Used in the `yank'
  21 and `yank-pop' commands.")
  22
  23 (defvar *current-prefix-arg* nil
  24   "The value of the prefix argument for this editing command.
  25 It may be a number, or the symbol `-' for just a minus sign as arg,
  26 or a list whose car is a number for just one or more C-u's
  27 or nil if no argument has been specified.
  28 This is what `(interactive \"P\")' returns.")
  29
  30 ;; (defun collect-command-args (cmd)
  31 ;;   "Return a list of values (some collected from the user) to pass to the CMD function."
  32 ;;   (mapcar (lambda (arg)
  33 ;;          (funcall (gethash (second arg) *command-arg-type-hash*)))
  34 ;;        (command-args cmd)))
  35
  36 (defvar *this-command-keys* nil
  37   "The key sequence that invoked the current command.")
  38
  39 (defun this-command-keys ()
  40   "Return the key sequence that invoked this command.
  41 The value is a list of KEYs."
  42   *this-command-keys*)
  43
  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                 (funcall (command-fn 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
 180 (defun top-level-next-event ()
 181   ;; Bind this locally so its value is restored after the
 182   ;; command is dispatched. Otherwise, calls to set-buffer
 183   ;; would stick.
 184   (setf *current-buffer* (window-buffer (frame-selected-window (selected-frame))))
 185   (catch :unbound-key
 186     (next-event)))
 187
 188 ;;; Key bindings
 189
 190 (define-key *global-map* "C-z" 'suspend-emacs)
 191 (define-key *ctl-x-map* "C-z" 'suspend-emacs)
 192 (define-key *global-map* "M-C-c" 'exit-recursive-edit)
 193 (define-key *global-map* "C-]" 'abort-recursive-edit)
 194 (define-key *global-map* "M-x" 'execute-extended-command)
 195
 196 (provide :lice-0.1/input)