/[mcclim]/mcclim/dialog.lisp
ViewVC logotype

Contents of /mcclim/dialog.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.14 - (show annotations)
Sun Oct 24 15:47:02 2004 UTC (9 years, 5 months ago) by moore
Branch: MAIN
Changes since 1.13: +53 -27 lines
Implemented :ALIGN-PROMPTS in ACCEPTING-VALUES. This was harder than
it sounds, requiring several changes and cleanups:

Moved the call to PROMPT-FOR-ACCEPT from ACCEPT to STREAM-ACCEPT. The
spec vaguely hints that ACCEPT is responsible for drawing the prompt,
but that makes things like wrapping the calls to PROMPT-FOR-ACCEPT
and ACCEPT-PRESENT-DEFAULT inside a table formatting directive hard
to do. This shouldn't affect any user code.

Made Goatee input streams play nice with output recording. Added the
notion of a NEWLINE-CHARACTER to Goatee buffers; NIL is valid, so one
can construct Goatee areas that will only have one line. This
eliminates a lot of ugliness from ACCEPTING-VALUES dialogs.

Fixed a few Goatee bugs.
1 ;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*-
2
3 ;;; (c) copyright 2003 by Tim Moore (moore@bricoworks.com)
4 ;;; This library is free software; you can redistribute it and/or
5 ;;; modify it under the terms of the GNU Library General Public
6 ;;; License as published by the Free Software Foundation; either
7 ;;; version 2 of the License, or (at your option) any later version.
8 ;;;
9 ;;; This library is distributed in the hope that it will be useful,
10 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
11 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
12 ;;; Library General Public License for more details.
13 ;;;
14 ;;; You should have received a copy of the GNU Library General Public
15 ;;; License along with this library; if not, write to the
16 ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
17 ;;; Boston, MA 02111-1307 USA.
18
19 #| Random notes:
20
21 An accepting-values stream diverts the calls to accept into calling
22 accept-present-default, as described in the spec. The output record
23 produced by accept-present-default, as well as the current value of
24 that query, arguments that were passed to accept, etc. are stored in a
25 query object. The stream stores all the query objects for this
26 invocation of accepting-values.
27
28 The query output records are presentations with command translators
29 defined that directly change their value (stored in the query object)
30 or select them for further user input, like the default text input.
31
32 After the initial output records are drawn, invoke-accepting-values
33 blocks accepting commands. When a query's value is changed, the body
34 of the call to accepting-values is run, with all the values returned
35 by calls to accept coming from the query objects.
36
37 |#
38
39 (in-package :clim-internals)
40
41 (defclass query ()
42 ((query-identifier :accessor query-identifier :initarg :query-identifier)
43 (ptype :accessor ptype :initarg :ptype)
44 (view :accessor view :initarg :view)
45 (default :accessor default :initarg :default :initform nil)
46 (default-supplied-p :accessor default-supplied-p
47 :initarg :default-supplied-p :initform nil)
48 (value :accessor value :initarg :value :initform nil)
49 (changedp :accessor changedp :initform nil)
50 (record :accessor record :initarg :record)
51 (activation-gestures :accessor activation-gestures
52 :initform *activation-gestures*
53 :documentation "Binding of *activation-gestures* on
54 entry to this accept")
55 (delimeter-gestures :accessor delimiter-gestures
56 :initform *delimiter-gestures*
57 :documentation "Binding of *delimeter-gestures* on entry
58 to this accept")
59 (accept-arguments :accessor accept-arguments :initarg :accept-arguments)
60 (accept-condition :accessor accept-condition :initarg :accept-condition
61 :initform nil
62 :documentation "Condition signalled, if any, during
63 accept of this query")))
64
65 (defclass accepting-values-record (standard-updating-output-record)
66 ())
67
68 (defclass accepting-values-stream (standard-encapsulating-stream)
69 ((queries :accessor queries :initform nil)
70 (selected-query :accessor selected-query :initform nil)
71 (align-prompts :accessor align-prompts :initarg :align-prompts
72 :initform nil)))
73
74 (defmethod stream-default-view ((stream accepting-values-stream))
75 +textual-dialog-view+)
76
77 (define-condition av-exit (condition)
78 ())
79
80 ;;; The accepting-values state machine is controlled by commands. Each
81 ;;; action (e.g., "select a text field") terminates
82
83 (define-command-table accepting-values) ; :inherit-from nil???
84
85 (defvar *default-command* '(accepting-values-default-command))
86
87 ;;; The fields of the query have presentation type query. Fields that
88 ;;; are "selectable", like the default text editor field, have type
89 ;;; selectable-query. The presentation object is the query
90 ;;; identifier.
91
92 (define-presentation-type query () :inherit-from t)
93
94 (define-presentation-type selectable-query () :inherit-from 'query)
95
96 (define-presentation-type exit-button () :inherit-from t)
97
98 (define-presentation-type abort-button () :inherit-from t)
99
100 (defvar *accepting-values-stream* nil)
101
102 (defmacro accepting-values
103 ((&optional (stream t)
104 &rest args
105 &key own-window exit-boxes initially-select-query-identifier
106 modify-initial-query resynchronize-every-pass resize-frame
107 align-prompts label scroll-bars
108 x-position y-position width height command-table frame-class)
109 &body body)
110 (declare (ignorable own-window exit-boxes initially-select-query-identifier
111 modify-initial-query resynchronize-every-pass resize-frame
112 align-prompts label scroll-bars
113 x-position y-position width height command-table frame-class))
114 (setq stream (stream-designator-symbol stream '*standard-input*))
115 (with-gensyms (accepting-values-continuation)
116 `(flet ((,accepting-values-continuation (,stream)
117 ,@body))
118 (invoke-accepting-values ,stream
119 #',accepting-values-continuation
120 ,@args))))
121
122 (defun invoke-accepting-values
123 (stream body
124 &key own-window exit-boxes
125 (initially-select-query-identifier nil initially-select-p)
126 modify-initial-query resynchronize-every-pass resize-frame
127 align-prompts label scroll-bars
128 x-position y-position width height
129 (command-table 'accepting-values)
130 (frame-class 'accept-values))
131 (declare (ignore own-window exit-boxes modify-initial-query
132 resize-frame label scroll-bars x-position y-position
133 width height frame-class))
134 (let* ((*accepting-values-stream*
135 (make-instance 'accepting-values-stream
136 :stream stream
137 :align-prompts align-prompts))
138 (arecord (updating-output (stream
139 :record-type 'accepting-values-record)
140 (if align-prompts
141 (formatting-table (stream)
142 (funcall body *accepting-values-stream*))
143 (funcall body *accepting-values-stream*))
144 (display-exit-boxes *application-frame*
145 stream
146 (stream-default-view
147 *accepting-values-stream*))))
148 (first-time t)
149 (current-command (if initially-select-p
150 `(com-select-query
151 ,initially-select-query-identifier)
152 *default-command*)))
153 (letf (((frame-command-table *application-frame*)
154 (find-command-table command-table)))
155 (unwind-protect
156 (handler-case
157 (loop
158 (if first-time
159 (setq first-time nil)
160 (when resynchronize-every-pass
161 (redisplay arecord stream)))
162 (with-input-context
163 ('(command :command-table accepting-values))
164 (object)
165 (progn
166 (apply (command-name current-command)
167 (command-arguments current-command))
168 ;; If current command returns without throwing a
169 ;; command, go back to the default command
170 (setq current-command *default-command*))
171 (t (setq current-command object)))
172 (redisplay arecord stream))
173 (av-exit ()
174 (finalize-query-records *accepting-values-stream*)
175 (redisplay arecord stream)))
176 (erase-output-record arecord stream)))))
177
178 (defgeneric display-exit-boxes (frame stream view))
179
180 (defmethod display-exit-boxes (frame stream (view textual-dialog-view))
181 (declare (ignore frame))
182 (updating-output (stream :unique-id 'buttons :cache-value t)
183 (fresh-line stream)
184 (with-output-as-presentation
185 (stream nil 'exit-button)
186 (format stream "Exit"))
187 (write-char #\space stream)
188 (with-output-as-presentation
189 (stream nil 'abort-button)
190 (format stream "Abort"))
191 (terpri stream)))
192
193 (defmethod stream-accept ((stream accepting-values-stream) type
194 &rest rest-args
195 &key
196 (view (stream-default-view stream))
197 (default nil default-supplied-p)
198 default-type
199 provide-default
200 insert-default
201 replace-input
202 history
203 active-p
204 prompt
205 prompt-mode
206 display-default
207 (query-identifier prompt)
208 activation-gestures
209 additional-activation-gestures
210 delimiter-gestures
211 additional-delimiter-gestures)
212 (declare (ignore activation-gestures additional-activation-gestures
213 delimiter-gestures additional-delimiter-gestures))
214 (let ((query (find query-identifier (queries stream)
215 :key #'query-identifier :test #'equal))
216 (align (align-prompts stream)))
217 (unless query
218 (setq query (make-instance 'query
219 :query-identifier query-identifier
220 :ptype type
221 :view view
222 :default default
223 :default-supplied-p default-supplied-p
224 :value default))
225 (setf (queries stream) (nconc (queries stream) (list query))))
226 (setf (accept-arguments query) rest-args)
227 ;; If the program changes the default, that becomes the value.
228 (unless (equal default (default query))
229 (setf (default query) default)
230 (setf (value query) default))
231 (flet ((do-prompt ()
232 (apply #'prompt-for-accept stream type view rest-args))
233 (do-accept-present-default ()
234 (funcall-presentation-generic-function
235 accept-present-default
236 type (encapsulating-stream-stream stream) view
237 (value query)
238 default-supplied-p nil query-identifier)))
239 (let ((query-record nil))
240 (if align
241 (formatting-row (stream)
242 (formatting-cell (stream :align-x align)
243 (do-prompt))
244 (formatting-cell (stream)
245 (setq query-record (do-accept-present-default))))
246 (progn
247 (do-prompt)
248 (setq query-record (do-accept-present-default))))
249 (setf (record query) query-record)
250 (when (accept-condition query)
251 (signal (accept-condition query)))
252 (multiple-value-prog1
253 (values (value query) (ptype query) (changedp query))
254 (setf (default query) default)
255 (setf (ptype query) type)
256 (setf (changedp query) nil))))))
257
258
259 (defmethod prompt-for-accept ((stream accepting-values-stream)
260 type view
261 &rest args)
262 (declare (ignore view))
263 (apply #'prompt-for-accept-1 stream type :display-default nil args))
264
265 (define-command (com-query-exit :command-table accepting-values
266 :name nil
267 :provide-output-destination-keyword nil)
268 ()
269 (signal 'av-exit))
270
271 (define-command (com-query-abort :command-table accepting-values
272 :name nil
273 :provide-output-destination-keyword nil)
274 ()
275 (and (find-restart 'abort)
276 (invoke-restart 'abort)))
277
278 (define-command (com-change-query :command-table accepting-values
279 :name nil
280 :provide-output-destination-keyword nil)
281 ((query-identifier t)
282 (value t))
283 (when *accepting-values-stream*
284 (let ((query (find query-identifier (queries *accepting-values-stream*)
285 :key #'query-identifier :test #'equal)))
286 (when query
287 (setf (value query) value)
288 (setf (changedp query) t)))))
289
290 (defgeneric select-query (stream query record)
291 (:documentation "Does whatever is needed for input (e.g., calls accept) when
292 a query is selected for input." ))
293
294 (defgeneric deselect-query (stream query record)
295 (:documentation "Deselect a query field: turn the cursor off, turn off
296 highlighting, etc." ))
297
298 (define-command (com-select-query :command-table accepting-values
299 :name nil
300 :provide-output-destination-keyword nil)
301 ((query-identifier t))
302 (when *accepting-values-stream*
303 (with-accessors ((selected-query selected-query))
304 *accepting-values-stream*
305 (let* ((query-list (member query-identifier
306 (queries *accepting-values-stream*)
307 :key #'query-identifier :test #'equal))
308 (query (car query-list)))
309 (when selected-query
310 (unless (equal query-identifier
311 (query-identifier selected-query))
312 (deselect-query *accepting-values-stream*
313 selected-query
314 (record selected-query))))
315 (when query
316 (setf selected-query query)
317 (select-query *accepting-values-stream* query (record query))
318 (if (cdr query-list)
319 (throw-object-ptype (query-identifier (cadr query-list))
320 'selectable-query)
321 (throw-object-ptype '(com-deselect-query)
322 '(command :command-table accepting-values))))))))
323
324 (define-command (com-deselect-query :command-table accepting-values
325 :name nil
326 :provide-output-destination-keyword nil)
327 ()
328 (when *accepting-values-stream*
329 (with-accessors ((selected-query selected-query))
330 *accepting-values-stream*
331 (when selected-query
332 (deselect-query *accepting-values-stream*
333 selected-query
334 (record selected-query))
335 (setf selected-query nil)))))
336
337 (defclass av-text-record (standard-updating-output-record)
338 ((editing-stream :accessor editing-stream)
339 (snapshot :accessor snapshot :initarg :snapshot :initform nil
340 :documentation "A copy of the stream buffer before accept
341 is called. Used to determine if any editing has been done by user")))
342
343 (defparameter *no-default-cache-value* (cons nil nil))
344
345 (define-default-presentation-method accept-present-default
346 (type stream (view textual-dialog-view) default default-supplied-p
347 present-p query-identifier)
348 (declare (ignore present-p))
349 (let* ((editing-stream nil)
350 (record (updating-output (stream :unique-id query-identifier
351 :cache-value (if default-supplied-p
352 default
353 *no-default-cache-value*)
354 :record-type 'av-text-record)
355 (with-output-as-presentation
356 (stream query-identifier 'selectable-query)
357 (surrounding-output-with-border
358 (stream :shape :drop-shadow :move-cursor t)
359 (setq editing-stream
360 (make-instance 'standard-input-editing-stream
361 :stream stream
362 :cursor-visibility nil
363 :background-ink +grey90+
364 :single-line t))))
365 (when default-supplied-p
366 (input-editing-rescan-loop ;XXX probably not needed
367 editing-stream
368 (lambda (s)
369 (presentation-replace-input s default type view
370 :rescan t)
371 (goatee::update-input-editing-stream s)))))))
372 (when editing-stream
373 (setf (editing-stream record) editing-stream))
374 record))
375
376 (defun av-do-accept (query record)
377 (let ((estream (editing-stream record))
378 (ptype (ptype query))
379 (view (view query))
380 (default (default query))
381 (default-supplied-p (default-supplied-p query)))
382 (setf (values (value query) (ptype query)) ; Hmm, should ptype be set here?
383 (input-editing-rescan-loop
384 estream
385 (if default-supplied-p
386 ;; Allow empty input to return a default value
387 #'(lambda (s)
388 (accept ptype :stream s :view view :prompt nil
389 :default default))
390 #'(lambda (s)
391 (accept ptype :stream s :view view :prompt nil)))))
392 (setf (changedp query) t)))
393
394
395
396 ;;; The desired
397 (defmethod select-query (stream query (record av-text-record))
398 (declare (ignore stream))
399 (let ((estream (editing-stream record))
400 (ptype (ptype query))
401 (view (view query))
402 (accept-args (accept-arguments query)))
403 (declare (ignore ptype view)) ;for now
404 (let* ((*activation-gestures* (apply #'make-activation-gestures
405 :existing-activation-gestures
406 (activation-gestures query)
407 accept-args))
408
409 (*delimiter-gestures* (apply #'make-delimiter-gestures
410 :existing-delimiter-args
411 (delimiter-gestures query)
412 accept-args)))
413 (with-accessors ((stream-activated stream-activated)
414 (stream-input-buffer stream-input-buffer))
415 estream
416 ;; "deactivate" editing stream if user has previously activated it.
417 (when stream-activated
418 (setf stream-activated nil)
419 (when (activation-gesture-p (aref stream-input-buffer
420 (1- (fill-pointer
421 stream-input-buffer))))
422 (replace-input estream ""
423 :buffer-start (1- (fill-pointer
424 stream-input-buffer))
425 :rescan t)))
426 (setf (cursor-visibility estream) t)
427 (setf (snapshot record) (copy-seq stream-input-buffer))
428 (block accept-condition-handler
429 (handler-bind ((condition #'(lambda (c)
430 (format *trace-output*
431 "accepting-values accept condition: ~A~%"
432 c)
433 (setf (accept-condition query) c)
434 (return-from accept-condition-handler
435 c))))
436 (av-do-accept query record)))))))
437
438
439
440 (defmethod deselect-query (stream query (record av-text-record))
441 (let ((estream (editing-stream record)))
442 (setf (cursor-visibility estream) nil)))
443
444 (defgeneric finalize-query-record (query record)
445 (:documentation "Do any cleanup on a query before the accepting-values body
446 is run for the last time"))
447
448 (defmethod finalize-query-record (query record)
449 nil)
450
451 ;;; If the user edits a text field, selects another text field and
452 ;;; then exits from accepting-values without activating the first
453 ;;; field, the values returned would be some previous value or default
454 ;;; for the field, not what's on the screen. That would be completely
455 ;;; bogus. So, if a field has been edited but not activated, activate
456 ;;; it now. Unfortunately that's a bit hairy.
457
458 (defmethod finalize-query-record (query (record av-text-record))
459 (let ((estream (editing-stream record)))
460 (when (and (not (stream-activated estream))
461 (snapshot record)
462 (not (equal (snapshot record)
463 (stream-input-buffer estream))))
464 (let* ((activation-gestures (apply #'make-activation-gestures
465 :existing-activation-gestures
466 (activation-gestures query)
467 (accept-arguments query)))
468 (gesture (car activation-gestures)))
469 (when gesture
470 (let ((c (character-gesture-name gesture)))
471 (replace-input estream (string c)
472 :buffer-start (fill-pointer (stream-input-buffer
473 estream))
474 :rescan nil)
475 (setf (stream-activated estream) t)
476 (reset-scan-pointer estream)
477 (av-do-accept query record)))))))
478
479 (defun finalize-query-records (av-stream)
480 (loop for query in (queries av-stream)
481 do (finalize-query-record query (record query))))
482
483
484 (define-presentation-to-command-translator com-select-field
485 (selectable-query com-select-query accepting-values
486 :gesture :select
487 :documentation "Select field for input"
488 :pointer-documentation "Select field for input"
489 :echo nil
490 :tester ((object)
491 (let ((selected (selected-query *accepting-values-stream*)))
492 (or (null selected)
493 (not (eq (query-identifier selected) object))))))
494 (object)
495 `(,object))
496
497 (define-presentation-to-command-translator com-exit-button
498 (exit-button com-query-exit accepting-values
499 :gesture :select
500 :documentation "Exit dialog"
501 :pointer-documentation "Exit dialog"
502 :echo nil)
503 ()
504 ())
505
506 (define-presentation-to-command-translator com-abort-button
507 (abort-button com-query-abort accepting-values
508 :gesture :select
509 :documentation "Abort dialog"
510 :pointer-documentation "Abort dialog"
511 :echo nil)
512 ()
513 ())
514
515 (defun accepting-values-default-command ()
516 (loop
517 (read-gesture :stream *accepting-values-stream*)))

  ViewVC Help
Powered by ViewVC 1.1.5