/[mcclim]/mcclim/Drei/input-editor.lisp
ViewVC logotype

Contents of /mcclim/Drei/input-editor.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.50 - (show annotations)
Wed Jun 3 20:33:16 2009 UTC (4 years, 10 months ago) by ahefner
Branch: MAIN
CVS Tags: HEAD
Changes since 1.49: +7 -0 lines
Handle selection-notify-events in the text gadget and input editor.
For communicating with the input editor, signal and handle a
selection-notify condition from the lower level event handler (I can't
think of a better approach to communicating across the layers). Disable
the old default of pasting by synthesizing keypress events, but make it
available via paste-as-keypress-mixin.
1 ;;; -*- Mode: Lisp; Package: DREI -*-
2
3 ;;; (c) copyright 2001 by
4 ;;; Tim Moore (moore@bricoworks.com)
5 ;;; (c) copyright 2006 by
6 ;;; Troels Henriksen (athas@sigkill.dk)
7
8 ;;; This library is free software; you can redistribute it and/or
9 ;;; modify it under the terms of the GNU Library General Public
10 ;;; License as published by the Free Software Foundation; either
11 ;;; version 2 of the License, or (at your option) any later version.
12 ;;;
13 ;;; This library is distributed in the hope that it will be useful,
14 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
15 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
16 ;;; Library General Public License for more details.
17 ;;;
18 ;;; You should have received a copy of the GNU Library General Public
19 ;;; License along with this library; if not, write to the
20 ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
21 ;;; Boston, MA 02111-1307 USA.
22
23 ;;; Implementation of various bits and parts needed for Drei to
24 ;;; function as the input-editor of McCLIM. Meaning, this is an
25 ;;; interface between input-editing-streams and Drei instances. We
26 ;;; also try not to mess too much with CLIM-INTERNALS to be somewhat
27 ;;; portable (but not too much).
28
29 (in-package :drei)
30
31 ;; Note that we use `stream-scan-pointer' to access the scan pointer
32 ;; of the stream in the protocol methods, despite the fact that the
33 ;; `drei-input-editing-mixin' class does not have a scan pointer. We
34 ;; assume that the subclass defines a scan pointer.
35 (defclass drei-input-editing-mixin ()
36 ((%drei-instance :accessor drei-instance-of
37 :initarg :drei-instance)
38 (%input-position :accessor input-position
39 :initform 0)
40 (%activation-gesture :accessor activation-gesture
41 :initform nil)
42 (%rescanning-p :reader stream-rescanning-p
43 :writer (setf stream-rescanning)
44 :initform nil)
45 (%input-buffer-array :accessor input-buffer-array
46 :initform nil
47 :documentation "After a command has been
48 executed, the contents of the Drei area instance shall be
49 replaced by the contents of this array, if non-NIL."))
50 (:documentation "An mixin that helps in implementing Drei-based
51 input-editing streams. This class should not be directly
52 instantiated."))
53
54 (defmethod initialize-instance :after ((obj drei-input-editing-mixin)
55 &rest args
56 &key stream
57 (cursor-visibility t)
58 (min-width 0))
59 (check-type min-width (or (integer 0) (eql t)))
60 (check-type stream clim-stream-pane)
61 (multiple-value-bind (cx cy)
62 (stream-cursor-position stream)
63 (let ((max-width (- (stream-text-margin stream) cx)))
64 (with-keywords-removed (args (:initial-contents))
65 (setf (drei-instance obj)
66 (apply #'make-instance
67 'drei-area
68 :editor-pane stream
69 :x-position cx
70 :y-position cy
71 :active cursor-visibility
72 :max-width max-width
73 :allow-other-keys t
74 args)))
75 ;; XXX Really add it here?
76 (stream-add-output-record stream (drei-instance obj)))))
77
78 (defmethod stream-default-view ((stream drei-input-editing-mixin))
79 (view (drei-instance stream)))
80
81 (defmethod stream-insertion-pointer
82 ((stream drei-input-editing-mixin))
83 (offset (point (view (drei-instance stream)))))
84
85 (defmethod (setf stream-insertion-pointer)
86 ((new-value integer) (stream drei-input-editing-mixin))
87 (setf (offset (point (view (drei-instance stream)))) new-value))
88
89 (defmethod cursor-visibility ((stream drei-input-editing-mixin))
90 (if (point-cursor (drei-instance stream))
91 (active (point-cursor (drei-instance stream)))
92 ;; Uh... no I guess?
93 nil))
94
95 (defmethod (setf cursor-visibility)
96 (visibility (stream drei-input-editing-mixin))
97 (setf (active (drei-instance stream)) visibility
98 (cursors-visible (drei-instance stream)) visibility))
99
100 (defclass drei-unselectable-presentation (presentation)
101 ()
102 (:documentation "A presentation that will not be highlightable,
103 and can thus be safely used for implementing stuff such as noise
104 strings."))
105
106 (define-presentation-translator unselectable-presentation-to-nothing
107 (drei-unselectable-presentation t global-command-table
108 :menu nil
109 :tester ((object)
110 (declare (ignore object))))
111 (object)
112 (declare (ignore object)))
113
114 (defclass noise-string (drei-unselectable-presentation)
115 ((%string :initarg :string
116 :initform (error "A noise string must represent some string.")
117 :reader noisy-string)
118 (%text-style :initarg :text-style
119 :initform (make-text-style :serif :italic nil)
120 :reader text-style))
121 (:documentation "Buffer objects of this class will be skipped
122 by the input-editor gesture reader. They should not be used
123 outside the input editor."))
124
125 (define-presentation-method present ((object noise-string) (type noise-string)
126 stream (view textual-view) &key &allow-other-keys)
127 (with-text-style (stream (text-style object))
128 (princ (noisy-string object) stream)))
129
130 (defclass accept-result (presentation)
131 ((%object :initarg :object
132 :initform (error "An object must be provided for the accept result.")
133 :reader object)
134 (%result-type :initarg :result-type
135 :initform t
136 :reader result-type))
137 (:documentation "Buffer objects of this class are inserted into
138 the buffer when the user clicks on an applicable presentation
139 while in an input context for the input-editor. They should not
140 be used outside the input-editor."))
141
142 (define-presentation-method present (object (type accept-result) stream
143 (view textual-view) &rest args
144 &key)
145 (apply #'present (object object) (result-type object) :stream stream :view view args))
146
147 (defmethod prompt-for-accept :around ((stream drei-input-editing-mixin) type view
148 &rest args &key &allow-other-keys)
149 (declare (ignore args))
150 ;; XXX: In Drei, the "input position" (a lovably underspecified
151 ;; concept in the CLIM spec) is just after any input prompt. We do
152 ;; not set the input position (or print the prompt) if we are
153 ;; already at the input position or if we are rescanning. This is so
154 ;; we can support fancy accept methods such as the one for
155 ;; `command-or-form'
156 (unless (stream-rescanning-p stream)
157 ;; Put the prompt in the proper place, but be super careful not to
158 ;; mess with the insertion pointer.
159 (let ((ip-clone (clone-mark (point (view (drei-instance stream))))))
160 (unwind-protect (progn (setf (stream-insertion-pointer stream)
161 (stream-scan-pointer stream))
162 (call-next-method))
163 (setf (stream-insertion-pointer stream) (offset ip-clone)))
164 (redraw-input-buffer stream)))
165 ;; We skip ahead of any noise strings to put us past the
166 ;; prompt. This is safe, because the noise strings are to be
167 ;; ignored anyway, but we need to be ahead to set the input
168 ;; position properly (ie. after the prompt).
169 (loop with buffer = (buffer (view (drei-instance stream)))
170 until (>= (stream-scan-pointer stream) (size buffer))
171 while (or (typep #1=(buffer-object buffer (stream-scan-pointer stream)) 'noise-string)
172 (delimiter-gesture-p #1#))
173 do (incf (stream-scan-pointer stream)))
174 (setf (input-position stream) (stream-scan-pointer stream)))
175
176 (defmethod stream-accept :after ((stream drei-input-editing-mixin) type &key &allow-other-keys)
177 ;; If we end up asking for more input using the stream, we do not
178 ;; want to permit the user to undo input for this context.
179 (clear-undo-history (buffer (view (drei-instance stream)))))
180
181 (defun buffer-array-mismatch (sequence1 sequence2
182 &key (from-end nil)
183 (start1 0)
184 (start2 0))
185 "Like `cl:mismatch', but supporting fewer keyword arguments,
186 and the two sequences can be Drei buffers instead."
187 (flet ((seq-elt (seq i)
188 (typecase seq
189 (drei-buffer (buffer-object seq i))
190 (array (aref seq i))))
191 (seq-length (seq)
192 (typecase seq
193 (drei-buffer (size seq))
194 (array (length seq)))))
195 (if from-end
196 (loop
197 for index1 downfrom (1- (seq-length sequence1)) to 0
198 for index2 downfrom (1- (seq-length sequence2)) to 0
199 unless (= index1 index2 0)
200 if (or (= index1 0)
201 (= index2 0))
202 return index1
203 unless (eql (seq-elt sequence1 index1)
204 (seq-elt sequence2 index2))
205 return (1+ index1))
206
207 (do* ((i1 start1 (1+ i1))
208 (i2 start2 (1+ i2))
209 x1 x2)
210 ((and (>= i1 (seq-length sequence1))
211 (>= i2 (seq-length sequence2))) nil)
212 (if (>= i1 (seq-length sequence1)) (return i1))
213 (if (>= i2 (seq-length sequence2)) (return i1))
214 (setq x1 (seq-elt sequence1 i1))
215 (setq x2 (seq-elt sequence2 i2))
216 (unless (eql x1 x2)
217 (return i1))))))
218
219 (defun synchronize-drei-buffer (stream)
220 "If the `input-buffer-array' of `stream' is non-NIL, copy the
221 contents of the array to the Drei buffer. This will set the
222 contents of the buffer to the contents of the array up to the
223 fill pointer."
224 (with-accessors ((array input-buffer-array)) stream
225 (let ((buffer (buffer (view (drei-instance stream)))))
226 (when array
227 ;; Attempt to minimise the changes to the buffer, so the
228 ;; position of marks will not be changed too much. Find the
229 ;; first mismatch between buffer contents and array contents.
230 (multiple-value-bind (index buffer-end array-end)
231 (let* ((buffer-array-mismatch-begin (or (buffer-array-mismatch
232 buffer array)
233 0))
234 (buffer-buffer-array-mismatch-end (or (buffer-array-mismatch
235 buffer array :from-end t
236 :start2 buffer-array-mismatch-begin)
237 buffer-array-mismatch-begin))
238 (array-buffer-array-mismatch-end (or (buffer-array-mismatch
239 array buffer :from-end t
240 :start2 buffer-array-mismatch-begin)
241 buffer-array-mismatch-begin)))
242 (values buffer-array-mismatch-begin
243 (max buffer-buffer-array-mismatch-end buffer-array-mismatch-begin)
244 (max array-buffer-array-mismatch-end buffer-array-mismatch-begin)))
245 (let ((insertion-pointer (stream-insertion-pointer stream)))
246 (when index ; NIL if buffer and array are identical.
247 ;; Delete from the first mismatch to the end of the
248 ;; mismatch.
249 (delete-buffer-range buffer index (- buffer-end index))
250 ;; Also delete from the end of the buffer if the array
251 ;; is smaller than the buffer.
252 (when (> (size buffer) (length array))
253 (delete-buffer-range buffer (length array)
254 (- (size buffer)
255 (length array))))
256 ;; Insert from the mismatch to end mismatch from the
257 ;; array into the buffer.
258 (insert-buffer-sequence buffer index (subseq array index array-end))
259 ;; Finally, see if it is possible to maintain the old
260 ;; position of the insertion pointer.
261 (setf (stream-insertion-pointer stream)
262 (min insertion-pointer (size buffer))))))))))
263
264 (defun synchronize-input-buffer-array (stream)
265 "If the `input-buffer-array' of `stream' is non-NIL, copy the
266 contents of the Drei buffer to the array. The fill pointer of the
267 array will point to after the last element."
268 (with-accessors ((array input-buffer-array)) stream
269 (let ((buffer (buffer (view (drei-instance stream)))))
270 (when array
271 (let ((new-array (buffer-sequence buffer 0 (size buffer))))
272 (setf array
273 ;; We probably lose if `adjust-array' doesn't
274 ;; destructively modify `array.
275 (adjust-array array (length new-array)
276 :initial-contents new-array
277 :fill-pointer (length new-array))))))))
278
279 (defun update-drei-buffer (stream)
280 "Update the Drei buffer of the Drei instance used by `stream'
281 if the `input-buffer-array' of `stream' is non-NIl. This will set
282 the contents of the buffer to the contents of the array up to the
283 fill pointer. Changes to the buffer will be recordes as
284 undoable. When this function returns, the `input-buffer-array' of
285 `stream' will be NIL. Also, the syntax will be up-to-date."
286 (with-undo ((list (buffer (view (drei-instance stream)))))
287 (synchronize-drei-buffer stream))
288 (setf (input-buffer-array stream) nil))
289
290 ;; While the CLIM spec says that user-commands are not allowed to do
291 ;; much with the input buffer, the Franz User Guide provides some
292 ;; examples that hint to the opposite. How do we make modifications of
293 ;; the input-buffer, which must be a standard array with a fill
294 ;; pointer, to be applied to the "real" buffer? This is how: when this
295 ;; method is called, we store the object in the stream object. In the
296 ;; command loop, we check the stream object and update the buffer
297 ;; (using `update-drei-buffer') to reflect the changes done to the
298 ;; buffer.
299 (defmethod stream-input-buffer ((stream drei-input-editing-mixin))
300 ;; NOTE: This is very slow (consing up a whole new array - twice!),
301 ;; please do not use it unless you want to be compatible with other
302 ;; editor substrates. Use the Drei buffer directly instead.
303 (unless (input-buffer-array stream)
304 ;; Create dummy array and synchronize it to the buffer contents.
305 (setf (input-buffer-array stream) (make-array 0 :fill-pointer 0))
306 (synchronize-input-buffer-array stream))
307 (input-buffer-array stream))
308
309 (defmethod replace-input ((stream drei-input-editing-mixin) (new-input array)
310 &key
311 (start 0)
312 (end (length new-input))
313 (buffer-start (input-position stream))
314 (rescan nil rescan-supplied-p))
315 (check-type start integer)
316 (check-type end integer)
317 (check-type buffer-start integer)
318 ;; Since this is a CLIM-specified function, we have to make sure the
319 ;; input-buffer-array is taken into consideration, because some
320 ;; input-editor-command might call this function and expect the
321 ;; changes to be reflected in the array it holds. Also, if changes
322 ;; have been made to the array, they need to be propagated to the
323 ;; buffer before we do anything.
324 (synchronize-drei-buffer stream)
325 (let* ((drei (drei-instance stream))
326 (view (view drei))
327 (new-contents (subseq new-input start end))
328 (old-contents (buffer-sequence (buffer view)
329 buffer-start
330 (stream-scan-pointer stream)))
331 (equal (and (= (length new-contents)
332 (length old-contents))
333 (every #'equal new-contents old-contents))))
334 (let ((begin-mark (clone-mark (point view))))
335 (unless equal
336 (setf (offset begin-mark) buffer-start)
337 (delete-region begin-mark (stream-scan-pointer stream))
338 (insert-sequence begin-mark new-contents)
339 ;; Make the buffer reflect the changes in the array.
340 (synchronize-input-buffer-array stream))
341 (display-drei drei)
342 ;; XXX: This behavior for the :rescan parameter is not mentioned
343 ;; explicitly in any CLIM guide, but McCLIM input-editing
344 ;; machinery relies on it.
345 (if (and (or rescan (not equal))
346 (not (and (null rescan) rescan-supplied-p)))
347 (queue-rescan stream)
348 (incf (stream-scan-pointer stream) (- (length new-contents)
349 (length old-contents))))
350 ;; We have to return "the position in the input buffer". We
351 ;; return the insertion position.
352 (stream-insertion-pointer stream))))
353
354 (defun present-acceptably-to-string (object type view for-context-type)
355 "Return two values - a string containing the printed
356 representation of `object' when presented with `type' and `view',
357 and an object. The second value will be NIL if the string is
358 \"acceptable\", that is, acceptable as input to the accept method
359 for `type', or `object' if it isn't."
360 (flet ((present-it (acceptably)
361 (present-to-string object type
362 :view view
363 :acceptably acceptably
364 :for-context-type for-context-type)))
365 (let* ((acceptably t)
366 (printed-rep nil))
367 (handler-case
368 (setq printed-rep (present-it t))
369 (error ()
370 (setq acceptably nil)
371 (setq printed-rep (present-it nil))))
372 (values printed-rep (if acceptably
373 nil
374 object)))))
375
376 (defmethod presentation-replace-input
377 ((stream drei-input-editing-mixin) object type view
378 &rest args &key (buffer-start (input-position stream))
379 rescan query-identifier (for-context-type type) (accept-result t))
380 (declare (ignore query-identifier buffer-start rescan))
381 ;; If the input is non-readable and `accept-result' is non-NIL, we
382 ;; insert an `accept-result' object into the buffer, otherwise we
383 ;; just insert the object itself. This is a non-specified
384 ;; convenience extension (so we have to use :allow-other-keys t when
385 ;; using it).
386 (with-keywords-removed (args (:type :view :query-identifier :for-context-type))
387 (multiple-value-bind (printed-rep accept-object)
388 (present-acceptably-to-string object type view for-context-type)
389 (apply #'replace-input stream
390 (if accept-object
391 (vector (if accept-result
392 (make-instance 'accept-result
393 :object accept-object
394 :result-type type)
395 accept-object))
396 printed-rep)
397 args))))
398
399 ;; The purpose of this method is to ensure that things such as lists
400 ;; should are not completely inserted as literal objects if they have
401 ;; unreadable elements.
402 (defmethod presentation-replace-input
403 ((stream drei-input-editing-mixin) object (type (eql 'expression)) view
404 &rest args &key
405 (buffer-start (input-position stream)) rescan
406 query-identifier (for-context-type type))
407 (declare (ignore query-identifier rescan for-context-type buffer-start))
408 ;; Build up an array, `insertion', and use `replace-input' to insert
409 ;; it.
410 (let ((insertion (make-array 10 :adjustable t :fill-pointer 0)))
411 (labels ((insert-object (object)
412 (vector-push-extend object insertion
413 (* (length insertion))))
414 (insert-objects (objects)
415 (setf insertion (adjust-array insertion
416 (+ (length insertion)
417 (length objects))
418 :fill-pointer (+ (fill-pointer insertion)
419 (length objects))))
420 (setf (subseq insertion (- (fill-pointer insertion)
421 (length objects))) objects))
422 (insert-list-in-stream (list)
423 (insert-object #\()
424 (mapl #'(lambda (cons)
425 (present-object (first cons))
426 (when (rest cons)
427 (insert-object #\Space)))
428 list)
429 (insert-object #\)))
430 (present-object (object)
431 (multiple-value-bind (printed-rep accept-object)
432 (present-acceptably-to-string object 'expression
433 +textual-view+ 'expression)
434 (if (null accept-object)
435 (insert-objects printed-rep)
436 (typecase object
437 (list (insert-list-in-stream object))
438 (array (insert-object #\#)
439 (insert-list-in-stream object))
440 (function (let ((name (nth-value 2 (function-lambda-expression object))))
441 (insert-objects (or (format nil "#'~A" name)
442 (vector object)))))
443 ;; Okay, we give up, just insert it.
444 (t (insert-object object)))))))
445 (present-object object))
446 (with-keywords-removed (args (:type :view :query-identifier :for-context-type))
447 (apply #'replace-input stream insertion args))))
448
449 (defmethod presentation-replace-input
450 ((stream drei-input-editing-mixin) object (type (eql 'form)) view
451 &rest args &key
452 (buffer-start (input-position stream)) rescan
453 query-identifier (for-context-type type))
454 (declare (ignore query-identifier rescan for-context-type buffer-start))
455 (apply #'presentation-replace-input stream object 'expression view args))
456
457 (defvar *drei-input-editing-stream* nil
458 "Used to provide CLIM-specified input-editing-commands with the
459 input-editing-stream. Bound when executing a command.")
460
461 ;;; Have to reexamine how many of the keyword arguments to
462 ;;; stream-read-gesture should really be passed to the encapsulated
463 ;;; stream.
464 ;;;
465 ;;; OK, now I know :) They should all be passed, except for peek-p.
466 ;;; However, the loop that calls stream-read-gesture on the
467 ;;; encapsulated stream needs to return null if we see a :timeout or
468 ;;; :eof.
469 ;;;
470 ;;; Activation gesture handling has been moved out of
471 ;;; stream-process-gesture to stream-read-gesture and
472 ;;; stream-unread-gesture. This allows a gesture to be read in while
473 ;;; it is not an activation gesture, unread, and then read again as an
474 ;;; activation gesture. This kind of game seems to be needed for
475 ;;; reading forms properly. -- moore
476 (defmethod stream-read-gesture ((stream drei-input-editing-mixin)
477 &rest rest-args &key peek-p
478 &allow-other-keys)
479 (with-keywords-removed (rest-args (:peek-p))
480 (rescan-if-necessary stream)
481 (with-accessors ((insertion-pointer stream-insertion-pointer)
482 (scan-pointer stream-scan-pointer)
483 (activation-gesture activation-gesture)) stream
484 (let ((buffer (buffer (view (drei-instance stream))))
485 (last-was-noisy nil)) ; T if last passed gesture is noise-string
486 (loop (loop while (< scan-pointer insertion-pointer)
487 while (< scan-pointer (size buffer))
488 do (let ((gesture (buffer-object buffer scan-pointer)))
489 ;; Skip noise strings.
490 (cond ((typep gesture 'noise-string)
491 (incf scan-pointer)
492 (setf last-was-noisy t))
493 ((and (not peek-p)
494 (typep gesture 'accept-result))
495 (incf scan-pointer)
496 #+(or mcclim building-mcclim)
497 (climi::throw-object-ptype (object gesture)
498 (result-type gesture)))
499 ;; Note that this implies that
500 ;; `stream-read-gesture' may return accept
501 ;; results, which might as well be arbitrary
502 ;; objects to the code calling
503 ;; `stream-read-gesture', since it can't really
504 ;; do anything with them except for asserting
505 ;; that they exist. According to the spec,
506 ;; "accept results are treated as a single
507 ;; gesture", and this kind of behavior is
508 ;; necessary to make sure `stream-read-gesture'
509 ;; doesn't simply claim that there are no more
510 ;; gestures in the input-buffer when the
511 ;; remaining gesture(s) is an accept result.
512 ((typep gesture 'accept-result)
513 (return-from stream-read-gesture gesture))
514 (t
515 (unless peek-p
516 (incf scan-pointer))
517 (return-from stream-read-gesture gesture)))))
518 (unless last-was-noisy ; This prevents double-prompting.
519 (setf (stream-rescanning stream) nil))
520 (when activation-gesture
521 (return-from stream-read-gesture
522 (prog1 activation-gesture
523 (unless peek-p
524 (setf activation-gesture nil)))))
525 ;; In McCLIM, stream-process-gesture is responsible for
526 ;; inserting characters into the buffer, changing the
527 ;; insertion pointer and possibly setting up the
528 ;; activation-gesture slot.
529 (loop with gesture and type
530 do (setf (values gesture type)
531 (apply #'stream-read-gesture
532 (encapsulating-stream-stream stream) rest-args))
533 when (null gesture)
534 do (return-from stream-read-gesture (values gesture type))
535 when (stream-process-gesture stream gesture type)
536 do (loop-finish)))))))
537
538 (defmethod stream-unread-gesture ((stream drei-input-editing-mixin)
539 gesture)
540 (with-accessors ((scan-pointer stream-scan-pointer)
541 (activation-gesture activation-gesture)) stream
542 (when (> scan-pointer 0)
543 (if (and (eql scan-pointer (stream-insertion-pointer stream))
544 (activation-gesture-p gesture))
545 (setf activation-gesture gesture)
546 (decf scan-pointer)))))
547
548 (defun read-gestures-and-act (stream first-gesture type)
549 "Read gestures from `stream' and act upon them as per the
550 semantics of `process-gesture'. This basically means that we read
551 gestures and process a command, returning NIL if we don't
552 consider it an \"editing command\", rescan if it changed
553 something before the scan pointer, and just return the gesture if
554 it inserted stuff after the scan pointer. `First-gesture' must be
555 the gesture that will be read in the first call to
556 `stream-read-gesture' for the stream encapsulated by
557 `stream'. The second return value of this function will be `type'
558 if stuff is inserted after the insertion pointer."
559 (assert (<= (input-position stream) (stream-scan-pointer stream)))
560 (let* ((drei (drei-instance stream))
561 (buffer (buffer (view drei)))
562 (*command-processor* drei)
563 (was-directly-processing (directly-processing-p drei))
564 (*drei-input-editing-stream* stream)
565 (old-buffer-contents (buffer-sequence buffer 0 (size buffer))))
566 (with-bound-drei-special-variables (drei :prompt "M-x ")
567 (update-drei-buffer stream)
568 ;; Since we have an unread gesture in the encapsulated stream,
569 ;; we should use that for further input. *standard-input* is
570 ;; bound back to the minibuffer (maybe) when an actual command
571 ;; is executed.
572 (let ((*standard-input* (encapsulating-stream-stream stream)))
573 ;; Commands are permitted to signal immediate rescans, but
574 ;; we may need to do some stuff first.
575 (unwind-protect
576 (accepting-from-user (drei)
577 ;; We narrow the buffer to the last object before
578 ;; input-position, so the user will not be able to
579 ;; delete arguments prompts or other things.
580 (drei-core:with-narrowed-buffer (drei
581 (loop for index from
582 (1- (input-position stream)) above 0
583 when (typep (buffer-object buffer index)
584 'noise-string)
585 return (1+ index)
586 finally (return 0))
587 t t)
588 (handler-case (process-gestures-or-command drei)
589 (climi::selection-notify (c)
590 (let* ((event (climi::event-of c))
591 (sheet (event-sheet event))
592 (port (port sheet)))
593 (when (eq *standard-input* sheet)
594 (insert-sequence (point (view drei))
595 (clim-backend:get-selection-from-event port event)))))
596 (unbound-gesture-sequence (c)
597 (display-message "~A is unbound" (gesture-name (gestures c))))
598 (abort-gesture (c)
599 (if (member (abort-gesture-event c)
600 *abort-gestures*
601 :test #'event-matches-gesture-name-p)
602 (signal 'abort-gesture :event (abort-gesture-event c))
603 (when was-directly-processing
604 (display-message "Aborted")))))))
605 (update-drei-buffer stream)))
606 (let ((first-mismatch (buffer-array-mismatch buffer old-buffer-contents)))
607 (display-drei drei :redisplay-minibuffer t)
608 (cond ((null first-mismatch)
609 ;; No change actually took place, even though IP may
610 ;; have moved.
611 nil)
612 ((< first-mismatch (stream-scan-pointer stream))
613 ;; Eek, change before scan pointer - this probably
614 ;; changes the scan, so we'll have to rescan
615 ;; everything. Bummer!
616 (immediate-rescan stream))
617 (t
618 ;; Something happened, but since we haven't even gotten
619 ;; to scanning that part of the buffer yet, it doesn't
620 ;; really matter. All that matters is that something
621 ;; happened, and that it modified the buffer. This is a
622 ;; somewhat liberal reading of the CLIM spec.
623 (values first-gesture type)))))))
624
625 (defmethod stream-process-gesture ((stream drei-input-editing-mixin)
626 gesture type)
627 ;; If some other command processor has taken control, we do not want
628 ;; to assume that an activation gesture really is an activation
629 ;; gesture. For example, #\Newline should not cause input activation
630 ;; if isearch is being performed.
631 (when (and (or (activation-gesture-p gesture)
632 (climi::gesture-match gesture *completion-gestures*)
633 (climi::gesture-match gesture *help-gestures*)
634 (climi::gesture-match gesture *possibilities-gestures*))
635 (directly-processing-p (drei-instance stream)))
636 (end-of-buffer (point (view (drei-instance stream))))
637 (unless (= (stream-scan-pointer stream)
638 (size (buffer (view (drei-instance stream)))))
639 (queue-rescan stream))
640 (setf (activation-gesture stream) gesture)
641 (rescan-if-necessary stream)
642 (return-from stream-process-gesture gesture))
643 (when (proper-gesture-p gesture)
644 (let ((*original-stream* (encapsulating-stream-stream stream)))
645 (unread-gesture gesture :stream (encapsulating-stream-stream stream))))
646 (read-gestures-and-act stream gesture type))
647
648 (defmethod reset-scan-pointer ((stream drei-input-editing-mixin)
649 &optional (scan-pointer 0))
650 (setf (stream-scan-pointer stream) scan-pointer
651 (stream-rescanning stream) t
652 (input-position stream) (min scan-pointer (input-position stream))))
653
654 ;; This has been cribbed from SPLIT-SEQUENCE and lightly modified.
655 (defun split-sequence (delimiter seq &key (count nil) (remove-empty-subseqs nil) (start 0) (end nil) (test nil test-supplied) (test-not nil test-not-supplied) (key nil key-supplied))
656 "Return a list of subsequences in seq delimited by delimiter.
657
658 If :remove-empty-subseqs is NIL, empty subsequences will be
659 included in the result; otherwise they will be discarded. All
660 other keywords work analogously to those for CL:SUBSTITUTE. The
661 second return value is an index suitable as an argument to
662 CL:SUBSEQ into the sequence indicating where processing stopped."
663 (let ((len (length seq))
664 (other-keys (nconc (when test-supplied
665 (list :test test))
666 (when test-not-supplied
667 (list :test-not test-not))
668 (when key-supplied
669 (list :key key)))))
670 (unless end (setq end len))
671 (loop for left = start then (+ right 1)
672 for right = (min (or (apply #'position delimiter seq
673 :start left
674 other-keys)
675 len)
676 end)
677 unless (and (= right left)
678 remove-empty-subseqs) ; empty subseq we don't want
679 if (and count (>= nr-elts count))
680 ;; We can't take any more. Return now.
681 return (values subseqs left)
682 else
683 collect (subseq seq left right) into subseqs
684 and sum 1 into nr-elts
685 until (>= right end)
686 finally (return (values subseqs right)))))
687
688 (defmethod input-editor-format ((stream drei-input-editing-mixin)
689 format-string
690 &rest format-args)
691 "Insert a noise string at the insertion-pointer of `stream'."
692 ;; Since everything inserted with this method is noise strings, we
693 ;; do not bother to modify the scan pointer or queue rescans.
694 (let* ((drei (drei-instance stream))
695 (output (apply #'format nil format-string format-args)))
696 (when (or (stream-rescanning-p stream)
697 (zerop (length output)))
698 (return-from input-editor-format nil))
699 ;; A noise string really should not contain a newline or Drei will
700 ;; malfunction. Of course, the newlines inserted this way aren't
701 ;; actually noise-strings. FIXME.
702 (loop for (seq . rest) on (split-sequence #\Newline output)
703 when (plusp (length seq))
704 do (insert-object (point (view drei))
705 (make-instance 'noise-string
706 :string seq))
707 unless (null rest)
708 do (insert-object (point (view drei)) #\Newline))))
709
710 (defmethod redraw-input-buffer ((stream drei-input-editing-mixin)
711 &optional (start-position 0))
712 (declare (ignore start-position))
713 ;; We ignore `start-position', because it would be more work to
714 ;; figure out what to redraw than to just redraw everything.
715 ;; We assume that this function is mostly called from non-Drei-aware
716 ;; code, and thus synchronise the input-editor-array with the Drei
717 ;; buffer before redisplaying.
718 (update-drei-buffer stream)
719 (display-drei (drei-instance stream)))
720
721 (defmethod erase-input-buffer ((stream drei-input-editing-mixin)
722 &optional (start-position 0))
723 (declare (ignore start-position))
724 ;; No-op, just to save older CLIM programs from dying.
725 nil)
726
727 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
728 ;;;
729 ;;; `Add-input-editor-command'
730 ;;;
731 ;;; The CLIM spec requires us to define a completely unusable function
732 ;;; for mapping gestures to functions in the input editor. Since the
733 ;;; CLIM spec does not define, or even suggest, any kind of
734 ;;; programmatic access to the data structures of the input-editor for
735 ;;; these function, it is utterly impossible to write portable
736 ;;; input-editor functions using this facility. Fortunately, Franz's
737 ;;; user guide saves us. An input-editor-command defined via this
738 ;;; facility takes four arguments: the input-editing stream, the input
739 ;;; buffer (ugh!), the gesture used to invoke the command, and the
740 ;;; accumulated numeric argument.
741
742 (defun add-input-editor-command (gestures function)
743 "Set up Drei so performing `gestures' will result in the
744 invocation of `function'. Only works for Drei-based input-editing
745 streams. `Function' will be called with four arguments: the
746 input-editing stream, the input buffer, the gesture used to
747 invoke the command, and the accumulated numeric argument."
748 (set-key `(,(lambda (numeric-argument)
749 (funcall function *drei-input-editing-stream*
750 (stream-input-buffer *drei-input-editing-stream*)
751 gestures
752 numeric-argument)) ,*numeric-argument-marker*)
753 'exclusive-input-editor-table
754 gestures))
755
756 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
757 ;;;
758 ;;; Presentation type specialization.
759
760 ;;; When starting out with reading `command-or-form', we use Lisp
761 ;;; syntax, so things like Structedit works. If it turns out to be a
762 ;;; command, switch back to Fundamental.
763
764 (define-presentation-method accept :around
765 ((type command-or-form)
766 (stream drei-input-editing-mixin)
767 view &key)
768 (with-drei-options ((drei-instance stream)
769 :syntax "Lisp"
770 :keep-syntax t)
771 (call-next-method)))
772
773 (define-presentation-method accept :around
774 ((type command)
775 (stream drei-input-editing-mixin)
776 view &key)
777 (with-drei-options ((drei-instance stream)
778 :syntax "Fundamental"
779 :keep-syntax nil)
780 (call-next-method)))
781
782 (define-presentation-method accept :around
783 ((type expression)
784 (stream drei-input-editing-mixin)
785 view
786 &key)
787 (with-drei-options ((drei-instance stream)
788 :syntax "Lisp"
789 :keep-syntax t)
790 (redraw-input-buffer stream)
791 (call-next-method)))
792
793 (define-presentation-method accept ((type expression)
794 (stream drei-input-editing-mixin)
795 (view textual-view)
796 &key)
797 (let ((*completion-gestures* nil)
798 (*possibilities-gestures* nil))
799 (with-delimiter-gestures (nil :override t)
800 (loop
801 named control-loop
802 with start-scan-pointer = (stream-scan-pointer stream)
803 with drei = (drei-instance stream)
804 with syntax = (syntax (view drei))
805 ;; The input context permits the user to mouse-select displayed
806 ;; Lisp objects and put them into the input buffer as literal
807 ;; objects.
808 for gesture = (with-input-context ('expression :override nil)
809 (object type)
810 (read-gesture :stream stream)
811 (expression (performing-drei-operations (drei :with-undo t
812 :redisplay t)
813 (presentation-replace-input
814 stream object type (view drei)
815 :buffer-start (stream-insertion-pointer stream)
816 :allow-other-keys t
817 :accept-result nil
818 :rescan t))
819 (rescan-if-necessary stream)
820 nil))
821 ;; True if `gesture' was freshly read from the user, and not
822 ;; just retrieved from the buffer during a rescan.
823 for freshly-inserted = (and (plusp (stream-scan-pointer stream))
824 (not (equal (buffer-object
825 (buffer (view drei))
826 (1- (stream-scan-pointer stream)))
827 gesture)))
828 for form = (drei-lisp-syntax::form-after syntax (input-position stream))
829 ;; We do not stop until the input is complete and an activation
830 ;; gesture has just been provided. The freshness check is so
831 ;; #\Newline characters in the input will not cause premature
832 ;; activation.
833 until (and (activation-gesture-p gesture)
834 (or (and freshly-inserted
835 (drei-lisp-syntax::form-complete-p form))))
836 when (and (activation-gesture-p gesture)
837 (null form))
838 do ;; We have to remove the buffer contents (whitespace,
839 ;; comments or error states, if this happens) or code
840 ;; above us will not believe us when we tell them that the
841 ;; input is empty
842 (delete-buffer-range (buffer (view drei)) start-scan-pointer
843 (- (stream-scan-pointer stream)
844 start-scan-pointer))
845 (setf (stream-scan-pointer stream) start-scan-pointer)
846 (simple-parse-error "Empty input")
847 ;; We only want to process the gesture if it is fresh, because
848 ;; if it isn't, it has already been processed at some point in
849 ;; the past.
850 when (and (activation-gesture-p gesture)
851 freshly-inserted)
852 do (with-activation-gestures (nil :override t)
853 (stream-process-gesture stream gesture nil))
854 finally (unread-gesture gesture :stream stream)
855 (let* ((object (handler-case
856 (drei-lisp-syntax:form-to-object syntax form
857 :read t
858 :package *package*)
859 (drei-lisp-syntax:form-conversion-error (e)
860 ;; Move point to the problematic form
861 ;; and signal a rescan.
862 (setf (activation-gesture stream) nil)
863 (handle-drei-condition drei e)
864 (display-drei drei :redisplay-minibuffer t)
865 (immediate-rescan stream))))
866 (ptype (presentation-type-of object)))
867 (return-from control-loop
868 (values object
869 (if (presentation-subtypep ptype 'expression)
870 ptype 'expression))))))))

  ViewVC Help
Powered by ViewVC 1.1.5