source: trunk/source/cocoa-ide/hemlock/src/views.lisp @ 14253

Last change on this file since 14253 was 14253, checked in by rme, 9 years ago

In update-echo-area-after-command: The cancel-message slot in a hemlock-view
object is just a string. Since loud-message is a format-like thingy, use
use "~a" so that a #\~ in the cancel-message string doesn't trip us up.

File size: 12.6 KB
1;;; -*- Mode: Lisp; Package: hemlock-internals -*-
3(in-package :hemlock-internals)
6;; A HEMLOCK-VIEW represents text displayed in a (pane inside a) window.
7;; Conceptually it consists of a text buffer, a modeline for semi-permanent status
8;; info, an echo area for transient status info, and a text input area for reading
9;; prompted input.  Currently the last two are conflated.
11;; A HEMLOCK-VIEW never changes which text buffer it displays (unlike in emacs).  A
12;; text buffer can be displayed in multiple HEMLOCK-VIEW's, although currently there
13;; is no UI to make that happen.  But we try take care to distinguish per-buffer info
14;; from per-view info.  The former is stored in the buffer struct and in buffer
15;; variables.  The latter is currently stored in HEMLOCK-VIEW slots, although I'd
16;; like to introduce user-definable "view variables" and get rid of some of these
17;; user-level slots.  [Note: currently, multiple views on a buffer are but a remote
18;; dream.  Basic things like the insertion point are still per buffer when they
19;; should be per view]
21;; The user interacts with a HEMLOCK-VIEW using events.  Each time the user presses a
22;; key, the OS arranges to invoke our event handler.  The event handler computes and
23;; invokes a hemlock command bound to the key.  The command is invoked in a
24;; dynamic context most suitable for modifying the text buffer associated with the
25;; HEMLOCK-VIEW, but by jumping through a few hoops, it can modify other buffers.
27(defvar *current-view* nil)
29(defun current-view (&optional (must-exist t))
30  (or *current-view*
31      (and must-exist (error "Hemlock view context not established"))))
33(defclass hemlock-view ()
34  ((pane :initarg :pane :reader hemlock-view-pane)
35   (buffer :initarg :buffer :reader hemlock-view-buffer)
36   (echo-area-buffer :initarg :echo-area-buffer :reader hemlock-echo-area-buffer)
37   (echo-area-stream :reader hemlock-echo-area-stream)
39   ;; Input state
40   (quote-next-p :initform nil :accessor hemlock-view-quote-next-p)
41   (current-command :initform (make-array 10 :fill-pointer 0 :adjustable t)
42                    :accessor hemlock-current-command)
43   (last-command :initform (make-array 10 :fill-pointer 0 :adjustable t)
44                 :accessor hemlock-last-command)
45   (prefix-argument-state :initform (make-prefix-argument-state)
46                          :accessor hemlock-prefix-argument-state)
47   ;; If set, events are diverted to the echo area for reading prompt-for-xxx input.
48   (prompted-input-state :initform nil :accessor hemlock-prompted-input-state)
50   (cancel-message :initform nil :accessor hemlock-cancel-message)
52   ;; User level "view variables", for now give each its own slot.
53   (last-command-type :initform nil :accessor hemlock-last-command-type)
54   (target-column :initform 0 :accessor hemlock-target-column)
55   ))
57(defun hemlock-view-p (object)
58  (typep object 'hemlock-view))
60(defmethod initialize-instance ((view hemlock-view) &key)
61  (call-next-method)
62  (with-slots (echo-area-buffer echo-area-stream) view
63    (setf echo-area-stream
64          (make-hemlock-output-stream (buffer-end-mark echo-area-buffer) :full))))
66(defun current-prefix-argument-state ()
67  (hemlock-prefix-argument-state (current-view)))
69(defun last-key-event-typed ()
70  "This function returns the last key-event typed by the user and read as input."
71  (let* ((view (current-view))
72         (keys (hemlock-current-command view)))
73    (when (= (length keys) 0) ;; the normal case, when executing a command.
74      (setq keys (hemlock-last-command view)))
75    (when (> (length keys) 0)
76      (aref keys (1- (length keys))))))
78(defun last-char-typed ()
79  (let ((key (last-key-event-typed)))
80    (and key (key-event-char key))))
82;; This handles errors in event handling.  It assumes it's called in a normal
83;; event handling context for some view.
84(defun lisp-error-error-handler (condition &key debug-p)
85  (with-standard-standard-output
86    (handler-case
87        (progn
88          (hemlock-ext:report-hemlock-error (current-view) condition debug-p)
89          (let ((emsg (ignore-errors (princ-to-string condition))))
90            (abort-to-toplevel (or emsg "Error"))))
91      (error (cc)
92             (ignore-errors (format t "~&Event error handling failed"))
93             (ignore-errors (format t ": ~a" cc))
94             (abort)))))
97;; This resets the command accumulation state in the current view.
98(defmethod reset-command-state ()
99  (let ((view (current-view)))
100    ;; This resets c-q
101    (setf (hemlock-view-quote-next-p view) nil)
102    ;; This resets c-x (multi-key command) and c-c (modifier prefix command)
103    (setf (fill-pointer (hemlock-current-command view)) 0)
104    ;; This resets the numarg state.
105    (prefix-argument-resetting-state (hemlock-prefix-argument-state view))))
107;; This is called for ^G and for lisp errors.  It aborts all editor state,
108;; including recursive reading input and incremental search.
109(defun abort-to-toplevel (&optional (message "Cancelled"))
110  ;; This assumes it's called in normal event state.
111  (assert (and *current-view* (find-restart 'exit-event-handler)))
112  (reset-command-state)
113  (invoke-hook hemlock::abort-hook) ;; reset ephemeral modes such as i-search.
114  (setf (hemlock-cancel-message (current-view)) message)
115  (let ((eps (current-echo-parse-state :must-exist nil)))
116    (when eps
117      (exit-echo-parse eps :aborted)))
118  (exit-event-handler))
120;; Called for editor errors.  This aborts command accumulation and i-search,
121;; but not recursive reading of input.
122(defun abort-current-command (&optional (message "Cancelled"))
123  ;; This assumes it's called in normal event state.
124  (assert (and *current-view* (find-restart 'exit-event-handler)))
125  (reset-command-state)
126  (invoke-hook hemlock::abort-hook)
127  (setf (hemlock-cancel-message (current-view)) message)
128  (exit-event-handler))
130(defun exit-event-handler (&optional message)
131  (when (and *current-view* message)
132    (setf (hemlock-cancel-message *current-view*) message))
133  (let ((restart (find-restart 'exit-event-handler)))
134    (if restart
135      (ccl::invoke-restart-no-return restart)
136      (abort))))
138;; These are only used in event handling, and as such are serialized
139(defparameter *translation-temp-1* (make-array 10 :fill-pointer 0 :adjustable t))
140(defparameter *translation-temp-2* (make-array 10 :fill-pointer 0 :adjustable t))
142(defmethod translate-and-lookup-command (keys)
143  ;; Returns NIL if we're in the middle of a command (either multi-key, as in c-x,
144  ;; or translation prefix, as in ESC for Meta-), else a command.
145  (multiple-value-bind (translated-key prefix-p)
146                       (translate-key keys *translation-temp-1* *translation-temp-2*)
147    (multiple-value-bind (res t-bindings)
148                         (get-current-binding translated-key)
149      (etypecase res
150        (command
151         (values res t-bindings))
152        (hash-table     ;; we're part-way through a multi-key command
153         nil)
154        (null
155         (if prefix-p   ;; we're part-way through a translation prefix
156           nil
157           (values (get-default-command) nil)))))))
160;; This has a side effect of resetting the quoting state and current command.
161(defmethod get-command-binding-for-key ((view hemlock-view) key)
162  (let ((current-keys (hemlock-current-command view)))
163    (vector-push-extend key current-keys)
164    (multiple-value-bind (main-binding t-bindings)
165                         (if (shiftf (hemlock-view-quote-next-p view) nil)
166                           (values (get-self-insert-command) nil)
167                           (let ((eps (hemlock-prompted-input-state view)))
168                             (or (and eps (eps-parse-key-handler eps))
169                                 (translate-and-lookup-command current-keys))))
170      (when main-binding
171        (let ((vec (hemlock-last-command view))) ;; reuse vector
172          (setf (hemlock-last-command view) current-keys)
173          (setf (fill-pointer vec) 0)
174          (setf (hemlock-current-command view) vec))
175        (values main-binding t-bindings)))))
177(defvar *last-last-command-type*)
178(defvar *last-prefix-argument*)
180(defun invoke-command (command p)
181  (funcall (command-function command) p))
183(defmethod execute-hemlock-key ((view hemlock-view) key)
184  #+debug (log-debug "~&execute-hemlock-key ~s" key)
185  (with-output-to-listener
186   (if (or (symbolp key) (functionp key))
187     (funcall key)
188     (multiple-value-bind (main-binding transparent-bindings)
189                          (get-command-binding-for-key view key)
190       #+debug (log-debug "~&  binding ~s ~s" main-binding transparent-bindings)
191       (ring-push key *key-event-history*)
192       ;; If the key represents an "alphabetic" character (of which there
193       ;; are about 94000), and the event has no modifiers or only a shift
194       ;; modifier, treat it if it were bound to "Self Insert".
196       (when (eq main-binding (get-default-command))
197         (let* ((modifiers (key-event-bits-modifiers (key-event-bits key)))
198                (char (key-event-char key)))
199           (when (and char
200                      (graphic-char-p char)
201                      (or (null modifiers)
202                          (equal '("Shift") modifiers)))
203             (setq main-binding (get-self-insert-command)))))
204       (when main-binding
205         (let* ((*last-last-command-type* (shiftf (hemlock-last-command-type view) nil))
206                (*last-prefix-argument* (hemlock::prefix-argument-resetting-state)))
207           (dolist (binding transparent-bindings)
208             (invoke-command binding *last-prefix-argument*))
209           (invoke-command main-binding *last-prefix-argument*)))))))
213(defmethod update-echo-area-after-command ((view hemlock-view))
214  (let* ((eps (hemlock-prompted-input-state view)))
215    ;;if we're in the process of returning from a recursive parse,
216    ;; don't do anything, let the outer event handle it.
217    (unless (and eps (eps-parse-results eps))
218      (let ((msg (shiftf (hemlock-cancel-message view) nil)))
219        (if msg
220          (loud-message "~a" msg)
221          ;; Echo command in progress if there is one, unless in a recursive parse
222          (unless eps
223            (let ((cmd (hemlock-current-command view)))
224              (unless (eql 0 (length cmd))
225                (let ((cstr (concatenate 'string (pretty-key-string cmd) " ")))
226                  (message cstr))))))))))
228(defmethod hemlock-view-current-buffer ((view hemlock-view))
229  (if (hemlock-prompted-input-state view)
230    (hemlock-echo-area-buffer view)
231    (hemlock-view-buffer view)))
233(defun buffer-modification-state (buffer)
234  (multiple-value-bind (start end) (buffer-selection-range buffer)
235    (list* (buffer-signature buffer) start end)))
237(defvar *next-view-start* nil)
239(defun set-scroll-position (how &optional where)
240  "Set the desired scroll position of the current view"
241  (when (markp where)
242    (unless (eq (mark-buffer where)
243                (hemlock-view-buffer (current-view)))
244      (error "~s is not a mark in the current view." where))
245    (setq where (mark-absolute-position where)))
246  (setf *next-view-start* (cons how where)))
248(defmethod handle-hemlock-event ((view hemlock-view) key)
249  ;; Key can also be a function, in which case it will get executed in the view event context
250  #+debug (log-debug "handle-hemlock-event ~s~:[~; (recursive)~]"
251                  key
252                  (and (eq view *current-view*)
253                       (eq (hemlock-view-current-buffer view) *current-buffer*)))
254  (if (and (eq view *current-view*)
255           (eq (hemlock-view-current-buffer view) *current-buffer*))
256    ;; KLUDGE: This might happen with stuff that normally switches buffers (e.g. meta-.)
257    ;; but happens not to.  Because of the stupid buffer binding/unbinding, it's currently
258    ;; problematic to just recurse here, so don't.
259    (progn
260      ;; TODO: should this catch exit-event or let outer one do it?  Check callers.
261      (execute-hemlock-key view key)
262      )
263    (ccl::with-standard-abort-handling "Abort editor event handling"
264      (let* ((*current-view* view)
265             (*current-buffer* (hemlock-view-current-buffer view))
266             (*next-view-start* nil) ;; gets set by scrolling commands
267             (text-buffer (hemlock-view-buffer view))
268             (mod (buffer-modification-state text-buffer)))
269        (modifying-buffer-storage (*current-buffer*)
270          (restart-case
271              (handler-bind ((error #'(lambda (c)
272                                        (lisp-error-error-handler c :debug-p t))))
273                (execute-hemlock-key view key))
274            (exit-event-handler () :report "Exit from hemlock event handler")))
275        ;; Update display
276        (if *next-view-start*
277          (destructuring-bind (how . where) *next-view-start*
278            (hemlock-ext:scroll-view view how where))
279          (unless (equal mod (buffer-modification-state text-buffer))
280            ;; Modified buffer, make sure user sees what happened
281            (hemlock-ext:ensure-selection-visible view)))
282        (update-echo-area-after-command view)))))
Note: See TracBrowser for help on using the repository browser.