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