/[mcclim]/mcclim/input-editing.lisp
ViewVC logotype

Contents of /mcclim/input-editing.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.75 - (show annotations)
Thu Oct 23 20:47:57 2008 UTC (5 years, 6 months ago) by thenriksen
Branch: MAIN
CVS Tags: HEAD
Changes since 1.74: +1 -1 lines
Spelling fixes from Mike Watters.
1 ;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*-
2
3 ;;; (c) copyright 2001 by
4 ;;; Tim Moore (moore@bricoworks.com)
5 ;;; (c) copyright 2006-2008 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 ;;; This file provides definitions of every part of input-editing that
24 ;;; can be defined without actually having loaded the input
25 ;;; editor. This is so more input-editor using code can be loaded
26 ;;; before loading Drei.
27
28 (in-package :clim-internals)
29
30 (defvar *use-goatee* nil
31 "If true, use the Goatee editing component instead of Drei. The
32 Goatee component is faster and more mature than Drei.")
33
34 (defvar *activation-gestures* nil
35 "The set of currently active activation gestures. The global
36 value of this must be NIL. The exact format of
37 `*activation-gestures*' is unspecified. `*activation-gestures*'
38 and the elements in it may have dynamic extent.")
39
40 (defvar *standard-activation-gestures* '(:newline :return)
41 "The default set of activation gestures. The exact set of
42 standard activation is unspecified, but must include the gesture
43 that corresponds to the #\Newline character. ")
44
45 (defvar *delimiter-gestures* nil
46 "The set of currently active delimiter gestures. The global
47 value of this must be NIL. The exact format of
48 `*delimiter-gestures*' is unspecified. `*delimiter-gestures*' and
49 the elements in it may have dynamic extent.")
50
51 (with-system-redefinition-allowed
52 (when (and (fboundp 'interactive-stream-p)
53 (not (typep (fdefinition 'interactive-stream-p)
54 'generic-function)))
55 (fmakunbound 'interactive-stream-p))
56 (defgeneric interactive-stream-p (stream)
57 (:method (stream)
58 (cl:interactive-stream-p stream))))
59
60 (defclass standard-input-editing-mixin ()
61 ((%typeout-record :accessor typeout-record
62 :initform nil
63 :documentation "The output record (if any)
64 that is the typeout information for this
65 input-editing-stream. `With-input-editor-typeout' manages this
66 output record."))
67 (:documentation "A mixin implementing some useful standard
68 behavior for input-editing streams."))
69
70 (defmethod typeout-record :around ((stream standard-input-editing-mixin))
71 ;; Can't do this in an initform, since we need to proper position...
72 (or (call-next-method)
73 (let ((record
74 (make-instance 'standard-sequence-output-record
75 :x-position 0
76 :y-position (bounding-rectangle-min-y
77 (input-editing-stream-output-record stream)))))
78 (stream-add-output-record (encapsulating-stream-stream stream)
79 record)
80 (setf (typeout-record stream) record))))
81
82 ;;; These helper functions take the arguments of ACCEPT so that they
83 ;;; can be used directly by ACCEPT.
84
85 (defun make-activation-gestures
86 (&key (activation-gestures nil activation-gestures-p)
87 (additional-activation-gestures nil additional-activations-p)
88 (existing-activation-gestures *activation-gestures*)
89 &allow-other-keys)
90 (cond (additional-activations-p
91 (append additional-activation-gestures existing-activation-gestures))
92 (activation-gestures-p
93 activation-gestures)
94 (t (or existing-activation-gestures
95 *standard-activation-gestures*))))
96
97 (defun make-delimiter-gestures
98 (&key (delimiter-gestures nil delimiter-gestures-p)
99 (additional-delimiter-gestures nil additional-delimiters-p)
100 (existing-delimiter-gestures *delimiter-gestures*)
101 &allow-other-keys)
102 (cond (additional-delimiters-p
103 (append additional-delimiter-gestures existing-delimiter-gestures))
104 (delimiter-gestures-p
105 delimiter-gestures)
106 (t existing-delimiter-gestures)))
107
108 (defmacro with-activation-gestures ((gestures &key override) &body body)
109 "Specifies a list of gestures that terminate input during the
110 execution of `body'. `Body' may have zero or more declarations as
111 its first forms. `Gestures' must be either a single gesture name
112 or a form that evaluates to a list of gesture names.
113
114 If the boolean `override' is true, then `gestures' will override
115 the current activation gestures. If it is false (the default),
116 then gestures will be added to the existing set of activation
117 gestures. `with-activation-gestures' must bind
118 `*activation-gestures*' to the new set of activation gestures.
119
120 See also the `:activation-gestures' and
121 `:additional-activation-gestures' options to `accept'."
122 ;; XXX Guess this implies that gestures need to be defined at
123 ;; compile time. Sigh. We permit both CLIM 2.0-style gesture names
124 ;; and CLIM 2.2 style characters.
125 (let ((gesture-form (cond ((or (and (symbolp gestures)
126 (gethash gestures *gesture-names*))
127 (characterp gestures))
128 `(list ',gestures))
129 (t gestures)))
130 (gestures (gensym))
131 (override-var (gensym)))
132 `(let* ((,gestures ,gesture-form) ;Preserve evaluation order of arguments
133 (,override-var ,override)
134 (*activation-gestures* (apply #'make-activation-gestures
135 (if ,override-var
136 :activation-gestures
137 :additional-activation-gestures)
138 (list ,gestures))))
139 ,@body)))
140
141 (defmacro with-delimiter-gestures ((gestures &key override) &body body)
142 "Specifies a list of gestures that terminate an individual
143 token, but not the entire input, during the execution of
144 `body'. `Body' may have zero or more declarations as its first
145 forms. `Gestures' must be either a single gesture name or a form
146 that evaluates to a list of gesture names.
147
148 If the boolean `override' is true, then `gestures' will override
149 the current delimiter gestures. If it is false (the default),
150 then gestures will be added to the existing set of delimiter
151 gestures. `With-delimiter-gestures' must bind
152 `*delimiter-gestures*' to the new set of delimiter
153 gestures.
154
155 See also the `:delimiter-gestures' and
156 `:additional-delimiter-gestures' options to `accept'."
157 ;; XXX Guess this implies that gestures need to be defined at
158 ;; compile time. Sigh. We permit both CLIM 2.0-style gesture names
159 ;; and CLIM 2.2 style characters.
160 (let ((gesture-form (cond ((or (and (symbolp gestures)
161 (gethash gestures *gesture-names*))
162 (characterp gestures))
163 `(list ',gestures))
164 (t gestures)))
165 (gestures (gensym))
166 (override-var (gensym)))
167 `(let* ((,gestures ,gesture-form) ;Preserve evaluation order of arguments
168 (,override-var ,override)
169 (*delimiter-gestures* (make-delimiter-gestures
170 (if ,override-var
171 :delimiter-gestures
172 :additional-delimiter-gestures)
173 ,gestures)))
174 ,@body)))
175
176 (defun activation-gesture-p (gesture)
177 "Returns true if the gesture object `gesture' is an activation
178 gesture, otherwise returns false."
179 (loop for gesture-name in *activation-gestures*
180 when (gesture-matches-spec-p gesture gesture-name)
181 do (return t)
182 finally (return nil)))
183
184 (defun delimiter-gesture-p (gesture)
185 "Returns true if the gesture object `gesture' is a delimiter
186 gesture, otherwise returns false."
187 (loop for gesture-name in *delimiter-gestures*
188 when (gesture-matches-spec-p gesture gesture-name)
189 do (return t)
190 finally (return nil)))
191
192 (defmacro with-input-editor-typeout ((&optional (stream t) &rest args
193 &key erase)
194 &body body)
195 "Clear space above the input-editing stream `stream' and
196 evaluate `body', capturing output done to `stream'. Place will be
197 obtained above the input-editing area and the output put
198 there. Nothing will be displayed until `body' finishes. `Stream'
199 is not evaluated and must be a symbol. If T (the default),
200 `*standard-input*' will be used. `Stream' will be bound to an
201 `extended-output-stream' while `body' is being evaluated."
202 (declare (ignore erase))
203 (check-type stream symbol)
204 (let ((stream (if (eq stream t) '*standard-output* stream)))
205 `(invoke-with-input-editor-typeout
206 ,stream
207 #'(lambda (,stream)
208 ,@body)
209 ,@args)))
210
211 (defgeneric invoke-with-input-editor-typeout (stream continuation &key erase)
212 (:documentation "Call `continuation' with a single argument, a
213 stream to do input-editor-typeout on."))
214
215 (defun sheet-move-output-vertically (sheet y delta-y)
216 "Move the output records of `sheet', starting at vertical
217 device unit offset `y' or below, down by `delta-y' device units,
218 then repaint `sheet'."
219 (unless (zerop delta-y)
220 (with-bounding-rectangle* (sheet-x1 sheet-y1 sheet-x2 sheet-y2) sheet
221 (declare (ignore sheet-x1 sheet-y1))
222 (map-over-output-records-overlapping-region
223 #'(lambda (record)
224 (multiple-value-bind (record-x record-y) (output-record-position record)
225 (when (> (+ record-y (bounding-rectangle-height record)) y)
226 (setf (output-record-position record)
227 (values record-x (+ record-y delta-y))))))
228 (stream-output-history sheet)
229 (make-bounding-rectangle 0 y sheet-x2 sheet-y2))
230 ;; Only repaint within the visible region...
231 (with-bounding-rectangle* (viewport-x1 viewport-y1 viewport-x2 viewport-y2)
232 (or (pane-viewport-region sheet) sheet)
233 (declare (ignore viewport-y1))
234 (repaint-sheet sheet (make-bounding-rectangle viewport-x1 (- y (abs delta-y))
235 viewport-x2 viewport-y2))))))
236
237 (defmethod invoke-with-input-editor-typeout ((editing-stream standard-input-editing-mixin)
238 (continuation function) &key erase)
239 (with-accessors ((stream-typeout-record typeout-record)) editing-stream
240 ;; Can't do this in an initform, as we need to set the proper
241 ;; output record position.
242 (let* ((encapsulated-stream (encapsulating-stream-stream editing-stream))
243 (old-min-y (bounding-rectangle-min-y stream-typeout-record))
244 (old-height (bounding-rectangle-height stream-typeout-record))
245 (new-typeout-record (with-output-to-output-record (encapsulated-stream
246 'standard-sequence-output-record
247 record)
248 (unless erase
249 ;; Steal the children of the old typeout record.
250 (map nil #'(lambda (child)
251 (setf (output-record-parent child) nil
252 (output-record-position child) (values 0 0))
253 (add-output-record child record))
254 (output-record-children stream-typeout-record))
255 ;; Make sure new output is done
256 ;; after the stolen children.
257 (stream-increment-cursor-position
258 encapsulated-stream 0 old-height))
259 (funcall continuation encapsulated-stream))))
260 (with-sheet-medium (medium encapsulated-stream)
261 (setf (output-record-position new-typeout-record) (values 0 old-min-y))
262 ;; Calculate the height difference between the old typeout and the new.
263 (let ((delta-y (- (bounding-rectangle-height new-typeout-record) old-height)))
264 (multiple-value-bind (typeout-x typeout-y)
265 (output-record-position new-typeout-record)
266 (declare (ignore typeout-x))
267 ;; Clear the old typeout...
268 (clear-output-record stream-typeout-record)
269 ;; Move stuff for the new typeout record...
270 (sheet-move-output-vertically encapsulated-stream typeout-y delta-y)
271 ;; Reuse the old stream-typeout-record...
272 (add-output-record new-typeout-record stream-typeout-record)
273 ;; Now, let there be light!
274 (repaint-sheet encapsulated-stream stream-typeout-record)))))))
275
276 (defun clear-typeout (&optional (stream t))
277 "Blank out the input-editor typeout displayed on `stream',
278 defaulting to T for `*standard-output*'."
279 (with-input-editor-typeout (stream :erase t)
280 (declare (ignore stream))))
281
282 (defmacro with-input-editing ((&optional (stream t)
283 &rest args
284 &key input-sensitizer (initial-contents "")
285 (class ''standard-input-editing-stream class-provided-p))
286 &body body)
287 "Establishes a context in which the user can edit the input
288 typed in on the interactive stream `stream'. `Body' is then
289 executed in this context, and the values returned by `body' are
290 returned as the values of `with-input-editing'. `Body' may have
291 zero or more declarations as its first forms.
292
293 The stream argument is not evaluated, and must be a symbol that
294 is bound to an input stream. If stream is T (the default),
295 `*standard-input*' is used. If stream is a stream that is not an
296 interactive stream, then `with-input-editing' is equivalent to
297 progn.
298
299 `input-sensitizer', if supplied, is a function of two arguments,
300 a stream and a continuation function; the function has dynamic
301 extent. The continuation, supplied by CLIM, is responsible for
302 displaying output corresponding to the user's input on the
303 stream. The input-sensitizer function will typically call
304 `with-output-as-presentation' in order to make the output
305 produced by the continuation sensitive.
306
307 If `initial-contents' is supplied, it must be either a string or
308 a list of two elements, an object and a presentation type. If it
309 is a string, the string will be inserted into the input buffer
310 using `replace-input'. If it is a list, the printed
311 representation of the object will be inserted into the input
312 buffer using `presentation-replace-input'."
313 (setq stream (stream-designator-symbol stream '*standard-input*))
314 (with-keywords-removed (args (:input-sensitizer :initial-contents :class))
315 `(invoke-with-input-editing ,stream
316 #'(lambda (,stream) ,@body)
317 ,input-sensitizer ,initial-contents
318 ,(if class-provided-p
319 class
320 `(if *use-goatee* 'goatee-input-editing-stream
321 ,class))
322 ,@args)))
323
324 (defmacro with-input-position ((stream) &body body)
325 (let ((stream-var (gensym "STREAM")))
326 `(let* ((,stream-var ,stream)
327 (*current-input-stream* (and (typep ,stream-var
328 'input-editing-stream)
329 ,stream-var))
330 (*current-input-position* (and *current-input-stream*
331 (stream-scan-pointer ,stream-var))))
332 ,@body)))
333
334 (defun input-editing-rescan-loop (editing-stream continuation)
335 (let ((start-scan-pointer (stream-scan-pointer editing-stream)))
336 (loop (block rescan
337 (handler-bind ((rescan-condition
338 #'(lambda (c)
339 (declare (ignore c))
340 (reset-scan-pointer editing-stream start-scan-pointer)
341 ;; Input-editing contexts above may be interested...
342 (return-from rescan nil))))
343 (return-from input-editing-rescan-loop
344 (funcall continuation editing-stream)))))))
345
346 (defgeneric finalize (editing-stream input-sensitizer)
347 (:documentation "Do any cleanup on an editing stream that is no
348 longer supposed to be used for editing, like turning off the
349 cursor, etc."))
350
351 (defmethod finalize ((stream input-editing-stream) input-sensitizer)
352 (clear-typeout stream)
353 (redraw-input-buffer stream))
354
355 (defgeneric invoke-with-input-editing
356 (stream continuation input-sensitizer initial-contents class)
357 (:documentation "Implements `with-input-editing'. `Class' is
358 the class of the input-editing stream to create, if necessary."))
359
360 (defmethod invoke-with-input-editing
361 (stream continuation input-sensitizer initial-contents class)
362 (declare (ignore input-sensitizer initial-contents class))
363 (funcall continuation stream))
364
365 (defmethod invoke-with-input-editing ((stream input-editing-stream)
366 continuation input-sensitizer
367 initial-contents class)
368 (unless (stream-rescanning-p stream)
369 (if (stringp initial-contents)
370 (replace-input stream initial-contents)
371 (presentation-replace-input stream
372 (first initial-contents)
373 (second initial-contents)
374 (stream-default-view stream))))
375 (call-next-method))
376
377 (defmethod invoke-with-input-editing :around ((stream extended-output-stream)
378 continuation
379 input-sensitizer
380 initial-contents
381 class)
382 (declare (ignore continuation input-sensitizer initial-contents class))
383 (letf (((cursor-visibility (stream-text-cursor stream)) nil))
384 (call-next-method)))
385
386 (defmethod invoke-with-input-editing :around (stream
387 continuation
388 input-sensitizer
389 initial-contents
390 class)
391 (declare (ignore continuation input-sensitizer initial-contents class))
392 (with-activation-gestures (*standard-activation-gestures*)
393 (call-next-method)))
394
395 (defgeneric input-editing-stream-output-record (stream)
396 (:documentation "Return the output record showing the display of the
397 input-editing stream `stream' values. This function does not
398 appear in the spec but is used by the command processing code for
399 layout and to implement a general with-input-editor-typeout."))
400
401 (defmethod input-editor-format ((stream t) format-string &rest format-args)
402 (unless (and (typep stream '#.*string-input-stream-class*)
403 (input-stream-p stream))
404 (apply #'format stream format-string format-args)))
405
406 (defun make-room (buffer pos n)
407 (let ((fill (fill-pointer buffer)))
408 (when (> (+ fill n)
409 (array-dimension buffer 0))
410 (adjust-array buffer (list (+ fill n))))
411 (incf (fill-pointer buffer) n)
412 (replace buffer buffer :start1 (+ pos n) :start2 pos :end2 fill)))
413
414 ;;; Defaults for replace-input and presentation-replace-input.
415
416 (defvar *current-input-stream* nil)
417 (defvar *current-input-position* 0)
418
419 (defun read-token (stream &key
420 (input-wait-handler *input-wait-handler*)
421 (pointer-button-press-handler
422 *pointer-button-press-handler*)
423 click-only)
424 "Reads characters from the interactive stream `stream' until it
425 encounters a delimiter or activation gesture, or a pointer
426 gesture. Returns the accumulated string that was delimited by the
427 delimiter or activation gesture, leaving the delimiter
428 unread.
429
430 If the first character of typed input is a quotation mark (#\"),
431 then `read-token' will ignore delimiter gestures until another
432 quotation mark is seen. When the closing quotation mark is seen,
433 `read-token' will proceed as above.
434
435 `Click-only' is ignored for now.
436
437 `Input-wait-handler' and `pointer-button-press-handler' are as
438 for 34stream-read-gesture"
439 (declare (ignore click-only)) ;XXX For now
440 (let ((result (make-array 1
441 :adjustable t
442 :fill-pointer 0
443 :element-type 'character))
444 (in-quotes nil))
445 ;; The spec says that read-token ignores delimiter gestures if the
446 ;; first character is #\", until it sees another. OK... what about
447 ;; other occurences of #\"? Guess we'll just accumulate them.
448 (loop for first-char = t then nil
449 for gesture = (read-gesture
450 :stream stream
451 :input-wait-handler input-wait-handler
452 :pointer-button-press-handler
453 pointer-button-press-handler)
454 do (cond ((or (null gesture)
455 (activation-gesture-p gesture)
456 (typep gesture 'pointer-button-event)
457 (and (not in-quotes)
458 (delimiter-gesture-p gesture)))
459 (loop-finish))
460 ((characterp gesture)
461 (if (eql gesture #\")
462 (cond (first-char
463 (setq in-quotes t))
464 (in-quotes
465 (setq in-quotes nil))
466 (t (vector-push-extend gesture result)))
467 (vector-push-extend gesture result)))
468 (t nil))
469 finally (progn
470 (when gesture
471 (unread-gesture gesture :stream stream))
472 ;; Return a simple string. XXX Would returning an
473 ;; adjustable string be so bad?
474 (return (subseq result 0))))))
475
476 (defun write-token (token stream &key acceptably)
477 "This function is the opposite of `read-token' given the string
478 token, it writes it to the interactive stream stream. If
479 `acceptably' is true and there are any characters in the token
480 that are delimiter gestures (see the macro
481 `with-delimiter-gestures'), then `write-token' will surround the
482 token with quotation marks (#\").
483
484 Typically, `present' methods will use `write-token' instead of
485 `write-string'."
486 (let ((put-in-quotes (and acceptably (some #'delimiter-gesture-p token))))
487 (when put-in-quotes
488 (write-char #\" stream))
489 (write-string token stream)
490 (when put-in-quotes
491 (write-char #\" stream))))
492
493 ;;; Signalling Errors Inside present (sic)
494
495 (define-condition simple-parse-error (simple-condition parse-error)
496 ()
497 (:documentation "The error that is signalled by
498 `simple-parse-error'. This is a subclass of `parse-error'.
499
500 This condition handles two initargs, `:format-string' and
501 `:format-arguments', which are used to specify a control string
502 and arguments for a call to `format'."))
503
504 (defun simple-parse-error (format-string &rest format-args)
505 "Signals a `simple-parse-error' error while parsing an input
506 token. Does not return. `Format-string' and `format-args' are as
507 for format."
508 (error 'simple-parse-error
509 :format-control format-string :format-arguments format-args))
510
511 (define-condition input-not-of-required-type (parse-error)
512 ((string :reader not-required-type-string :initarg :string)
513 (type :reader not-required-type-type :initarg :type))
514 (:report (lambda (condition stream)
515 (format stream "Input ~S is not of required type ~S"
516 (not-required-type-string condition)
517 (not-required-type-type condition))))
518 (:documentation "The error that is signalled by
519 `input-not-of-required-type'. This is a subclass of
520 `parse-error'.
521
522 This condition handles two initargs, `:string' and `:type', which
523 specify a string to be used in an error message and the expected
524 presentation type."))
525
526 (defun input-not-of-required-type (object type)
527 "Reports that input does not satisfy the specified type by
528 signalling an `input-not-of-required-type' error. `Object' is a
529 parsed object or an unparsed token (a string). `Type' is a
530 presentation type specifier. Does not return."
531 (error 'input-not-of-required-type :string object :type type))
532
533 ;;; 24.5 Completion
534
535 (defvar *completion-gestures* '(:complete)
536 "A list of the gesture names that cause `complete-input' to
537 complete the user's input as fully as possible. The exact global
538 contents of this list is unspecified, but must include the
539 `:complete' gesture name.")
540
541 (defvar *help-gestures* '(:help)
542 "A list of the gesture names that cause `accept' and
543 `complete-input' to display a (possibly input context-sensitive)
544 help message, and for some presentation types a list of
545 possibilities as well. The exact global contents of this list is
546 unspecified, but must include the `:help' gesture name.")
547
548 (defvar *possibilities-gestures* '(:possibilities)
549 "A list of the gesture names that cause `complete-input' to
550 display a (possibly input context-sensitive) help message and a
551 list of possibilities. The exact global contents of this list is
552 unspecified, but must include the `:possibilities' gesture
553 name.")
554
555 (define-condition simple-completion-error (simple-parse-error)
556 ((input-so-far :reader completion-error-input-so-far
557 :initarg :input-so-far))
558 (:documentation "The error that is signalled by
559 `complete-input' when no completion is found. This is a subclass
560 of `simple-parse-error'."))
561
562 ;;; wrapper around event-matches-gesture-name-p to match against characters too.
563
564 (defgeneric gesture-matches-spec-p (gesture spec)
565 (:documentation "Match a gesture against a gesture name or character."))
566
567 (defmethod gesture-matches-spec-p (gesture (spec symbol))
568 (event-matches-gesture-name-p gesture spec))
569
570 (defmethod gesture-matches-spec-p ((gesture character) (spec character))
571 (char-equal gesture spec))
572
573 (defmethod gesture-matches-spec-p (gesture spec)
574 (declare (ignore gesture spec))
575 nil)
576
577 (defun gesture-match (gesture list)
578 "Returns t if gesture matches any gesture spec in list."
579 (some #'(lambda (name)
580 (gesture-matches-spec-p gesture name))
581 list))
582
583 ;;; Helpers for complete-input, which is just getting too long.
584
585 (defun complete-gesture-p (gesture)
586 (or (delimiter-gesture-p gesture) (activation-gesture-p gesture)))
587
588 ;;; Break out rescanning case for complete-input.
589 ;;;
590 ;;; funky logic; we don't know if we're still rescanning until after the call
591 ;;; to read-gesture.
592 (defun complete-input-rescan (stream func partial-completers so-far
593 allow-any-input)
594 (when (stream-rescanning-p stream)
595 (loop for gesture = (read-gesture :stream stream :timeout 0)
596 while (and gesture (stream-rescanning-p stream))
597 if (complete-gesture-p gesture)
598 do (let (input success object nmatches)
599 (when (gesture-match gesture partial-completers)
600 (setf (values input success object nmatches)
601 (funcall func (subseq so-far 0) :complete-limited)))
602 (unless (and (numberp nmatches) (> nmatches 0))
603 ;; Not a partial match; better be a total match
604 (setf (values input success object)
605 (funcall func (subseq so-far 0) :complete))
606 (if (or success allow-any-input)
607 (progn
608 (unread-gesture gesture :stream stream)
609 (return-from complete-input-rescan
610 (values object t input)))
611 ;; This used to be an error, but no one thought
612 ;; that was a really great idea.
613 (signal 'simple-completion-error
614 :format-control "complete-input: While rescanning,~
615 can't match ~A~A"
616 :format-arguments (list so-far gesture)
617
618 :input-so-far so-far))))
619 end
620 do (vector-push-extend gesture so-far)
621 finally (when gesture
622 (unread-gesture gesture :stream stream))))
623 nil)
624
625 (defun possibilities-for-menu (possibilities)
626 (loop for (display object) in possibilities
627 collect `(,display :value ,object)))
628
629 (defun possibility-printer (possibility ptype stream)
630 "A default function for printing a possibility. Suitable for
631 used as value of `:possibility-printer' in calls to
632 `complete-input'"
633 (with-output-as-presentation (stream possibility ptype)
634 (write-string (first possibility) stream)))
635
636 (defun print-possibilities (possibilities possibility-printer stream)
637 "Write `possibitilies' to `stream', using
638 `possibility-printer'. `Possibilities' must be a list of
639 input-completion possibilities. `Stream' must be an input-editing
640 stream. Output will be done to its typeout."
641 (with-input-editor-typeout (stream :erase t)
642 (surrounding-output-with-border (stream :shape :drop-shadow :background +cornsilk1+)
643 (surrounding-output-with-border (stream :shape :rectangle)
644 (let ((ptype `(completion ,possibilities)))
645 (format-items possibilities
646 :stream stream
647 :printer #'(lambda (possibility stream)
648 (funcall possibility-printer
649 possibility
650 ptype
651 stream))))))))
652
653 ;;; Helper returns gesture (or nil if gesture shouldn't be part of the input)
654 ;;; and completion mode, if any.
655
656 (defvar *completion-possibilities-continuation* nil)
657
658 (defun read-completion-gesture (stream
659 partial-completers
660 help-displays-possibilities)
661 (flet ((possibilitiesp (gesture)
662 (or (gesture-match gesture *possibilities-gestures*)
663 (and help-displays-possibilities
664 (gesture-match gesture *help-gestures*)))))
665 (let ((*completion-possibilities-continuation*
666 #'(lambda ()
667 (return-from read-completion-gesture
668 (values nil :possibilities)))))
669 (handler-bind ((accelerator-gesture
670 #'(lambda (c)
671 (let ((gesture (accelerator-gesture-event c)))
672 (when (possibilitiesp gesture)
673 (return-from read-completion-gesture
674 (values nil :possibilities)))))))
675 (let ((gesture (read-gesture :stream stream)))
676 (values gesture
677 (cond ((possibilitiesp gesture)
678 :possibilities)
679 ((gesture-match gesture partial-completers)
680 :complete-limited)
681 ((gesture-match gesture *completion-gestures*)
682 :complete-maximal)
683 ((complete-gesture-p gesture)
684 :complete)
685 (t nil))))))))
686
687 (defparameter *trace-complete-input* nil)
688
689 (defun complete-input (stream func &key
690 partial-completers allow-any-input
691 (possibility-printer #'possibility-printer)
692 (help-displays-possibilities t))
693 (let ((so-far (make-array 1 :element-type 'character :adjustable t
694 :fill-pointer 0))
695 (*accelerator-gestures* (append *help-gestures*
696 *possibilities-gestures*
697 *accelerator-gestures*)))
698 (with-input-position (stream)
699 (flet ((insert-input (input)
700 (adjust-array so-far (length input)
701 :fill-pointer (length input))
702 (replace so-far input)
703 ;; XXX: Relies on non-specified behavior of :rescan.
704 (replace-input stream input :rescan nil)))
705 (multiple-value-bind (object success input)
706 (complete-input-rescan stream func partial-completers
707 so-far allow-any-input)
708 (when success
709 (return-from complete-input (values object success input))))
710 (loop
711 (multiple-value-bind (gesture mode)
712 (read-completion-gesture stream
713 partial-completers
714 help-displays-possibilities)
715 (if mode
716 (multiple-value-bind
717 (input success object nmatches possibilities)
718 (funcall func (subseq so-far 0) mode)
719 (when (and (zerop nmatches)
720 (eq mode :complete-limited)
721 (complete-gesture-p gesture))
722 ;; Gesture is both a partial completer and a
723 ;; delimiter e.g., #\space. If no partial match,
724 ;; try again with a total match.
725 (setf (values input success object nmatches possibilities)
726 (funcall func (subseq so-far 0) :complete))
727 (setf mode :complete))
728 ;; Preserve the delimiter
729 (when (and success (eq mode :complete))
730 (unread-gesture gesture :stream stream))
731 ;; Get completion from menu
732 (when *trace-complete-input*
733 (format *trace-output* "nmatches = ~A, mode = ~A~%"
734 nmatches mode))
735 (when (and (> nmatches 0) (eq mode :possibilities))
736 (print-possibilities possibilities possibility-printer stream)
737 (redraw-input-buffer stream)
738 (let ((possibility
739 (handler-case
740 (with-input-context (`(completion ,possibilities) :override nil)
741 (object type event)
742 (prog1 nil (read-gesture :stream stream :peek-p t))
743 (t object))
744 (abort-gesture () nil))))
745 (if possibility
746 (setf (values input success object nmatches)
747 (values (first possibility) t (second possibility) 1))
748 (setf success nil
749 nmatches 0))))
750 (unless (and (eq mode :complete) (not success))
751 (if (> nmatches 0)
752 (insert-input input)
753 (beep)))
754 (cond ((and success (eq mode :complete))
755 (return-from complete-input
756 (values object success input)))
757 ((activation-gesture-p gesture)
758 (if allow-any-input
759 (return-from complete-input
760 (values nil t (subseq so-far 0)))
761 (error 'simple-completion-error
762 :format-control "Input ~S does not match"
763 :format-arguments (list so-far)
764 :input-so-far so-far)))))
765 (vector-push-extend gesture so-far))))))))
766
767 ;;; helper function
768
769 (defun left-prefix (string1 string2 &key (end nil))
770 "Returns the common prefix of string1 and string2, up to end"
771 (let* ((end1 (if end
772 (min (length string1) end)
773 nil))
774 (end2 (if end
775 (min (length string2) end)
776 nil))
777 (mismatch (mismatch string1 string2 :test #'char-equal
778 :end1 end1 :end2 end2)))
779 (cond (mismatch
780 (subseq string1 0 mismatch))
781 (end
782 (subseq string1 0 end))
783 (t string1))))
784
785 (defun complete-from-generator (initial-string generator delimiters &key
786 (action :complete)
787 (predicate (constantly t)))
788 (when (eq action :possibilities)
789 (return-from complete-from-generator
790 (complete-from-generator-possibilities initial-string
791 generator
792 predicate)))
793 (let ((initial-string-len (length initial-string))
794 (candidate-match nil)
795 (matches 0)
796 (object nil)
797 (identical nil)
798 (identical-match nil)
799 (identical-object nil)
800 (actual-match nil))
801 (flet ((suggester (str obj)
802 (unless (funcall predicate obj)
803 (return-from suggester nil))
804 (let ((partial-match-end
805 (and (eq action :complete-limited)
806 (>= (length str) initial-string-len)
807 (position-if #'(lambda (c) (member c delimiters))
808 str
809 :start initial-string-len))))
810 (when (and (eq action :complete-limited)
811 (null partial-match-end))
812 (return-from suggester nil))
813 (unless partial-match-end
814 (setq partial-match-end (1- (length str))))
815 (let ((mismatch-initial (mismatch initial-string str
816 :test #'char-equal)))
817 (cond ((and mismatch-initial
818 (>= mismatch-initial (length initial-string)))
819 (incf matches)
820 (unless candidate-match
821 (setq object obj))
822 (setf candidate-match
823 (cond (candidate-match
824 (left-prefix candidate-match
825 str
826 :end (1+ partial-match-end)))
827 (partial-match-end
828 (subseq str 0 (1+ partial-match-end)))
829 (t str))
830 actual-match str))
831 ((null mismatch-initial)
832 (incf matches)
833 ;; If there's a longer match we want to find it.
834 (if (eq action :complete-maximal)
835 (progn
836 (setf identical-match str)
837 (setf identical-object obj))
838 (progn
839 (setf candidate-match str)
840 (setf object obj)))
841 (setf identical t)))))))
842 (funcall generator initial-string #'suggester)
843 (let ((partial-match-before-end (and (eq action :complete-limited)
844 (eql matches 1)
845 (< (length candidate-match)
846 (length actual-match)))))
847 (values (or candidate-match identical-match initial-string)
848 (or (and identical
849 (or (not (eq action :complete-maximal))
850 (eql matches 1)))
851 (and (eql matches 1)
852 (not partial-match-before-end)))
853 (if (eq action :complete-maximal)
854 (cond ((and (eql matches 2) identical-match)
855 object)
856 ((and identical-match (eql matches 1))
857 identical-object)
858 ((eql matches 1)
859 object))
860 (and (or identical (and (eql matches 1)
861 (not partial-match-before-end)))
862 object))
863 matches
864 nil)))))
865
866 ;;; The possibilities action is different enough that I don't want to add to
867 ;;; the spaghetti above...
868
869 (defun complete-from-generator-possibilities
870 (initial-string generator predicate)
871 (let ((possibilities nil)
872 (nmatches 0)
873 (initial-len (length initial-string)))
874 (flet ((suggester (str obj)
875 (unless (funcall predicate obj)
876 (return-from suggester nil))
877 (when (>= (or (mismatch initial-string str :test #'char-equal)
878 (length initial-string))
879 initial-len)
880 (incf nmatches)
881 (push (list str obj) possibilities))))
882 (funcall generator initial-string #'suggester)
883 (if (and (eql nmatches 1)
884 (string-equal initial-string (caar possibilities)))
885 ;; return values are as from complete-from-generator, qv.
886 (values (caar possibilities)
887 t
888 (cdar possibilities)
889 nmatches
890 possibilities)
891 (values initial-string nil nil nmatches (sort possibilities #'string-lessp :key #'car))))))
892
893 (defun complete-from-possibilities (initial-string completions delimiters &key
894 (action :complete)
895 (predicate (constantly t))
896 (name-key #'car)
897 (value-key #'second))
898 (flet ((generator (input-string suggester)
899 (declare (ignore input-string))
900 (do-sequence (possibility completions)
901 (funcall suggester
902 (funcall name-key possibility)
903 (funcall value-key possibility)))))
904 (complete-from-generator initial-string #'generator delimiters
905 :action action
906 :predicate predicate)))
907
908 (defun suggest (completion object)
909 "Specifies one possibility for
910 `completing-from-suggestions'. `Completion' is a string, the
911 printed representation of object. `Object' is the internal
912 representation.
913
914 Calling this function outside of the body of
915 `completing-from-suggestions' is an error."
916 (declare (ignore completion object))
917 (error
918 "SUGGEST called outside of lexical scope of COMPLETING-FROM-SUGGESTIONS" ))
919
920 (defmacro completing-from-suggestions ((stream &rest args) &body body)
921 "Reads input from the input editing stream `stream', completing
922 over a set of possibilities generated by calls to `suggest'
923 within `body'. `Body' may have zero or more declarations as its
924 first forms.
925
926 `Completing-from-suggestions' returns three values, `object',
927 `success', and `string'.
928
929 The stream argument is not evaluated, and must be a symbol that
930 is bound to a stream. If `stream' t is (the default),
931 `*standard-input*' is used. `Partial-completers',
932 `allow-any-input', and `possibility-printer' are as for
933 `complete-input'.
934
935 Implementations will probably use `complete-from-generator' to
936 implement this."
937 (when (eq stream t)
938 (setq stream '*standard-input*))
939 (let ((generator (gensym "GENERATOR"))
940 (input-string (gensym "INPUT-STRING"))
941 (suggester (gensym "SUGGESTER")))
942 `(flet ((,generator (,input-string ,suggester)
943 (declare (ignore ,input-string))
944 (flet ((suggest (completion object)
945 (funcall ,suggester completion object)))
946 ,@body)))
947 ;; This sucks, but we can't use args to the macro directly because
948 ;; we want the partial-delimiters argument and we need to insure its
949 ;; proper evaluation order with everything else.
950 (let* ((complete-input-args (list ,@args))
951 (partial-completers (getf complete-input-args
952 :partial-completers
953 nil)))
954 (apply #'complete-input
955 ,stream
956 #'(lambda (so-far mode)
957 (complete-from-generator so-far
958 #',generator
959 partial-completers
960 :action mode))
961 complete-input-args)))))
962
963 ;;; Infrasructure for detecting empty input, thus allowing accept-1
964 ;;; to supply a default.
965
966 (defmacro handle-empty-input ((stream) input-form &body handler-forms)
967 "Establishes a context on `stream' (a `standard-input-editing-stream') in
968 which empty input entered in `input-form' may transfer control to
969 `handler-forms'. Empty input is assumed when a simple-parse-error is
970 signalled and there is a delimeter gesture or activation gesture in the
971 stream at the position where `input-form' began its input. The gesture that
972 caused the transfer remains to be read in `stream'. Control is transferred to
973 the outermost `handle-empty-input' form that is empty.
974
975 Note: noise strings in the buffer, such as the prompts of recursive calls to
976 `accept', cause input to not be empty. However, the prompt generated by
977 `accept' is generally not part of its own empty input context."
978 (with-gensyms (input-cont handler-cont)
979 `(flet ((,input-cont ()
980 ,input-form)
981 (,handler-cont ()
982 ,@handler-forms))
983 (declare (dynamic-extent #',input-cont #',handler-cont))
984 (invoke-handle-empty-input ,stream #',input-cont #',handler-cont))))
985
986 (define-condition empty-input-condition (simple-condition)
987 ((stream :reader empty-input-condition-stream :initarg :stream)))
988
989 ;;; The code that signalled the error might have consumed the gesture, or
990 ;;; not.
991 ;;; XXX Actually, it would be a violation of the `accept' protocol to consume
992 ;;; the gesture, but who knows what random accept methods are doing.
993 (defun empty-input-p
994 (stream begin-scan-pointer activation-gestures delimiter-gestures)
995 (let ((scan-pointer (stream-scan-pointer stream))
996 (fill-pointer (fill-pointer (stream-input-buffer stream))))
997 ;; activated?
998 (cond ((and (eql begin-scan-pointer scan-pointer)
999 (eql scan-pointer fill-pointer))
1000 t)
1001 ((or (eql begin-scan-pointer scan-pointer)
1002 (eql begin-scan-pointer (1- scan-pointer)))
1003 (let ((gesture (aref (stream-input-buffer stream)
1004 begin-scan-pointer)))
1005 (and (characterp gesture)
1006 (or (gesture-match gesture activation-gestures)
1007 (gesture-match gesture delimiter-gestures)))))
1008 (t nil))))
1009
1010 ;;; The control flow in here might be a bit confusing. The handler catches
1011 ;;; parse errors from accept forms and checks if the input stream is empty. If
1012 ;;; so, it resignals an empty-input-condition to see if an outer call to
1013 ;;; accept is empty and wishes to handle this situation. We don't resignal the
1014 ;;; parse error itself because it might get handled by a handler on ERROR in an
1015 ;;; accept method or in user code, which would screw up the default mechanism.
1016 ;;;
1017 ;;; If the situation is not handled in the innermost empty input handler,
1018 ;;; either directly or as a result of resignalling, then it won't be handled
1019 ;;; by any of the outer handlers as the stack unwinds, because EMPTY-INPUT-P
1020 ;;; will return nil.
1021 (defun invoke-handle-empty-input
1022 (stream input-continuation handler-continuation)
1023 (unless (input-editing-stream-p stream)
1024 (return-from invoke-handle-empty-input (funcall input-continuation)))
1025 (let ((begin-scan-pointer (stream-scan-pointer stream))
1026 (activation-gestures *activation-gestures*)
1027 (delimiter-gestures *delimiter-gestures*))
1028 (block empty-input
1029 (handler-bind (((or simple-parse-error empty-input-condition)
1030 #'(lambda (c)
1031 (when (empty-input-p stream
1032 begin-scan-pointer
1033 activation-gestures
1034 delimiter-gestures)
1035 (if (typep c 'empty-input-condition)
1036 (signal c)
1037 (signal 'empty-input-condition :stream stream))
1038 ;; No one else wants to handle it, so we will
1039 (return-from empty-input nil)))))
1040 (return-from invoke-handle-empty-input (funcall input-continuation))))
1041 (funcall handler-continuation)))

  ViewVC Help
Powered by ViewVC 1.1.5