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

Contents of /mcclim/dialog.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.17 - (show annotations)
Tue Jan 18 10:58:08 2005 UTC (9 years, 3 months ago) by tmoore
Branch: MAIN
Changes since 1.16: +43 -9 lines
Implemented a pop-up-menu-view for displaying the completion
presentation type in a dialog.

Added some documentation for the internals of accepting-values.
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. The record created and returned by
27 accept-present-default must be a subclass of updating-output-record.
28
29 After the initial output records are drawn, invoke-accepting-values
30 blocks accepting commands. The state of the dialog state machine is changed
31 via these commands. The commands currently are:
32
33 COM-SELECT-QUERY query-id -- calls the method select-query with the
34 corresponding query object and output record object. When select-query returns
35 the "next" field, if any, is selected so the user can move from field to field
36 easily.
37
38 COM-CHANGE-QUERY query-id value -- This command is used to directly change the
39 value of a query field that does not need to be selected first for input. For
40 example, a user would click directly on a radio button without selecting the
41 gadget first.
42
43 COM-DESELECT-QUERY -- deselects the currently selected query.
44
45 COM-QUERY-EXIT -- Exits accepting-values
46
47 COM-QUERY-ABORT -- Aborts accepting-values
48
49 These commands are generated in two ways. For query fields that are entirely
50 based on CLIM drawing commands and presentations, these are emitted by
51 presentation translators. There is a presentation type selectable-query that
52 throws com-select-query for the :select gesture. Fields that are based on
53 gadgets have to throw presentations from their callbacks. This can be done
54 using the method on p. 305 of the Franz CLIM user guide, or by using the
55 McCLIM function throw-object-ptype.
56
57 After a command is executed the body of accepting-values is rerun, calling
58 accept-present-default again to update the fields' graphic appearance. [This
59 may be calling these methods too often an may change in the future]. The
60 values returned by the user's calls to accept are come from the query objects.
61
62
63 If a query field is selectable than it should implement the method
64 select-query:
65
66 SELECT-QUERY stream query record -- Make a query field active and do any
67 input. This should change the query object and setf (changedp query). This
68 method might be interrupted at any time if the user selects another field.
69
70 |#
71
72 (in-package :clim-internals)
73
74 (defclass query ()
75 ((query-identifier :accessor query-identifier :initarg :query-identifier)
76 (ptype :accessor ptype :initarg :ptype)
77 (view :accessor view :initarg :view)
78 (default :accessor default :initarg :default :initform nil)
79 (default-supplied-p :accessor default-supplied-p
80 :initarg :default-supplied-p :initform nil)
81 (value :accessor value :initarg :value :initform nil)
82 (changedp :accessor changedp :initform nil)
83 (record :accessor record :initarg :record)
84 (activation-gestures :accessor activation-gestures
85 :initform *activation-gestures*
86 :documentation "Binding of *activation-gestures* on
87 entry to this accept")
88 (delimeter-gestures :accessor delimiter-gestures
89 :initform *delimiter-gestures*
90 :documentation "Binding of *delimeter-gestures* on entry
91 to this accept")
92 (accept-arguments :accessor accept-arguments :initarg :accept-arguments)
93 (accept-condition :accessor accept-condition :initarg :accept-condition
94 :initform nil
95 :documentation "Condition signalled, if any, during
96 accept of this query")))
97
98 (defclass accepting-values-record (standard-updating-output-record)
99 ())
100
101 (defclass accepting-values-stream (standard-encapsulating-stream)
102 ((queries :accessor queries :initform nil)
103 (selected-query :accessor selected-query :initform nil)
104 (align-prompts :accessor align-prompts :initarg :align-prompts
105 :initform nil)))
106
107 (defmethod stream-default-view ((stream accepting-values-stream))
108 +textual-dialog-view+)
109
110 (define-condition av-exit (condition)
111 ())
112
113 ;;; The accepting-values state machine is controlled by commands. Each
114 ;;; action (e.g., "select a text field") terminates
115
116 (define-command-table accepting-values) ; :inherit-from nil???
117
118 (defvar *default-command* '(accepting-values-default-command))
119
120 ;;; The fields of the query have presentation type query. Fields that
121 ;;; are "selectable", like the default text editor field, have type
122 ;;; selectable-query. The presentation object is the query
123 ;;; identifier.
124
125 (define-presentation-type query () :inherit-from t)
126
127 (define-presentation-type selectable-query () :inherit-from 'query)
128
129 (define-presentation-type exit-button () :inherit-from t)
130
131 (define-presentation-type abort-button () :inherit-from t)
132
133 (defvar *accepting-values-stream* nil)
134
135 (defmacro accepting-values
136 ((&optional (stream t)
137 &rest args
138 &key own-window exit-boxes initially-select-query-identifier
139 modify-initial-query resynchronize-every-pass resize-frame
140 align-prompts label scroll-bars
141 x-position y-position width height command-table frame-class)
142 &body body)
143 (declare (ignorable own-window exit-boxes initially-select-query-identifier
144 modify-initial-query resynchronize-every-pass resize-frame
145 align-prompts label scroll-bars
146 x-position y-position width height command-table frame-class))
147 (setq stream (stream-designator-symbol stream '*standard-input*))
148 (with-gensyms (accepting-values-continuation)
149 `(flet ((,accepting-values-continuation (,stream)
150 ,@body))
151 (invoke-accepting-values ,stream
152 #',accepting-values-continuation
153 ,@args))))
154
155 (defun invoke-accepting-values
156 (stream body
157 &key own-window exit-boxes
158 (initially-select-query-identifier nil initially-select-p)
159 modify-initial-query resynchronize-every-pass resize-frame
160 align-prompts label scroll-bars
161 x-position y-position width height
162 (command-table 'accepting-values)
163 (frame-class 'accept-values))
164 (declare (ignore own-window exit-boxes modify-initial-query
165 resize-frame label scroll-bars x-position y-position
166 width height frame-class))
167 (multiple-value-bind (cx cy) (stream-cursor-position stream)
168 (let* ((*accepting-values-stream*
169 (make-instance 'accepting-values-stream
170 :stream stream
171 :align-prompts align-prompts))
172 (arecord (updating-output (stream
173 :record-type 'accepting-values-record)
174 (if align-prompts
175 (formatting-table (stream)
176 (funcall body *accepting-values-stream*))
177 (funcall body *accepting-values-stream*))
178 (display-exit-boxes *application-frame*
179 stream
180 (stream-default-view
181 *accepting-values-stream*))))
182 (first-time t)
183 (current-command (if initially-select-p
184 `(com-select-query
185 ,initially-select-query-identifier)
186 *default-command*)))
187 (letf (((frame-command-table *application-frame*)
188 (find-command-table command-table)))
189 (unwind-protect
190 (handler-case
191 (loop
192 (if first-time
193 (setq first-time nil)
194 (when resynchronize-every-pass
195 (redisplay arecord stream)))
196 (with-input-context
197 ('(command :command-table accepting-values))
198 (object)
199 (progn
200 (apply (command-name current-command)
201 (command-arguments current-command))
202 ;; If current command returns without throwing a
203 ;; command, go back to the default command
204 (setq current-command *default-command*))
205 (t (setq current-command object)))
206 (redisplay arecord stream))
207 (av-exit ()
208 (finalize-query-records *accepting-values-stream*)
209 (redisplay arecord stream)))
210 (erase-output-record arecord stream)
211 (setf (stream-cursor-position stream)
212 (values cx cy)))))))
213
214 (defgeneric display-exit-boxes (frame stream view))
215
216 (defmethod display-exit-boxes (frame stream (view textual-dialog-view))
217 (declare (ignore frame))
218 (updating-output (stream :unique-id 'buttons :cache-value t)
219 (fresh-line stream)
220 (with-output-as-presentation
221 (stream nil 'exit-button)
222 (format stream "Exit"))
223 (write-char #\space stream)
224 (with-output-as-presentation
225 (stream nil 'abort-button)
226 (format stream "Abort"))
227 (terpri stream)))
228
229 (defmethod stream-accept ((stream accepting-values-stream) type
230 &rest rest-args
231 &key
232 (view (stream-default-view stream))
233 (default nil default-supplied-p)
234 default-type
235 provide-default
236 insert-default
237 replace-input
238 history
239 active-p
240 prompt
241 prompt-mode
242 display-default
243 (query-identifier prompt)
244 activation-gestures
245 additional-activation-gestures
246 delimiter-gestures
247 additional-delimiter-gestures)
248 (declare (ignore activation-gestures additional-activation-gestures
249 delimiter-gestures additional-delimiter-gestures))
250 (let ((query (find query-identifier (queries stream)
251 :key #'query-identifier :test #'equal))
252 (align (align-prompts stream)))
253 (unless query
254 (setq query (make-instance 'query
255 :query-identifier query-identifier
256 :ptype type
257 :view view
258 :default default
259 :default-supplied-p default-supplied-p
260 :value default))
261 (setf (queries stream) (nconc (queries stream) (list query))))
262 (setf (accept-arguments query) rest-args)
263 ;; If the program changes the default, that becomes the value.
264 (unless (equal default (default query))
265 (setf (default query) default)
266 (setf (value query) default))
267 (flet ((do-prompt ()
268 (apply #'prompt-for-accept stream type view rest-args))
269 (do-accept-present-default ()
270 (funcall-presentation-generic-function
271 accept-present-default
272 type (encapsulating-stream-stream stream) view
273 (value query)
274 default-supplied-p nil query-identifier)))
275 (let ((query-record nil))
276 (if align
277 (formatting-row (stream)
278 (formatting-cell (stream :align-x align)
279 (do-prompt))
280 (formatting-cell (stream)
281 (setq query-record (do-accept-present-default))))
282 (progn
283 (do-prompt)
284 (setq query-record (do-accept-present-default))))
285 (setf (record query) query-record)
286 (when (accept-condition query)
287 (signal (accept-condition query)))
288 (multiple-value-prog1
289 (values (value query) (ptype query) (changedp query))
290 (setf (default query) default)
291 (setf (ptype query) type)
292 (setf (changedp query) nil))))))
293
294
295 (defmethod prompt-for-accept ((stream accepting-values-stream)
296 type view
297 &rest args)
298 (declare (ignore view))
299 (apply #'prompt-for-accept-1 stream type :display-default nil args))
300
301 (define-command (com-query-exit :command-table accepting-values
302 :name nil
303 :provide-output-destination-keyword nil)
304 ()
305 (signal 'av-exit))
306
307 (define-command (com-query-abort :command-table accepting-values
308 :name nil
309 :provide-output-destination-keyword nil)
310 ()
311 (and (find-restart 'abort)
312 (invoke-restart 'abort)))
313
314 (define-command (com-change-query :command-table accepting-values
315 :name nil
316 :provide-output-destination-keyword nil)
317 ((query-identifier t)
318 (value t))
319 (when *accepting-values-stream*
320 (let ((query (find query-identifier (queries *accepting-values-stream*)
321 :key #'query-identifier :test #'equal)))
322 (when query
323 (setf (value query) value)
324 (setf (changedp query) t)))))
325
326 (defgeneric select-query (stream query record)
327 (:documentation "Does whatever is needed for input (e.g., calls accept) when
328 a query is selected for input. It is responsible for updating the
329 query object when a new value is entered in the query field." ))
330
331 (defgeneric deselect-query (stream query record)
332 (:documentation "Deselect a query field: turn the cursor off, turn off
333 highlighting, etc." ))
334
335 (define-command (com-select-query :command-table accepting-values
336 :name nil
337 :provide-output-destination-keyword nil)
338 ((query-identifier t))
339 (when *accepting-values-stream*
340 (with-accessors ((selected-query selected-query))
341 *accepting-values-stream*
342 (let* ((query-list (member query-identifier
343 (queries *accepting-values-stream*)
344 :key #'query-identifier :test #'equal))
345 (query (car query-list)))
346 (when selected-query
347 (unless (equal query-identifier
348 (query-identifier selected-query))
349 (deselect-query *accepting-values-stream*
350 selected-query
351 (record selected-query))))
352 (when query
353 (setf selected-query query)
354 (select-query *accepting-values-stream* query (record query))
355 (let ((command-ptype '(command :command-table accepting-values)))
356 (if (cdr query-list)
357 (throw-object-ptype `(com-select-query ,(query-identifier
358 (cadr query-list)))
359 command-ptype)
360 (throw-object-ptype '(com-deselect-query) command-ptype))))))))
361
362 (define-command (com-deselect-query :command-table accepting-values
363 :name nil
364 :provide-output-destination-keyword nil)
365 ()
366 (when *accepting-values-stream*
367 (with-accessors ((selected-query selected-query))
368 *accepting-values-stream*
369 (when selected-query
370 (deselect-query *accepting-values-stream*
371 selected-query
372 (record selected-query))
373 (setf selected-query nil)))))
374
375 (defclass av-text-record (standard-updating-output-record)
376 ((editing-stream :accessor editing-stream)
377 (snapshot :accessor snapshot :initarg :snapshot :initform nil
378 :documentation "A copy of the stream buffer before accept
379 is called. Used to determine if any editing has been done by user")))
380
381 (defparameter *no-default-cache-value* (cons nil nil))
382
383 ;;; Hack until more views / dialog gadgets are defined.
384
385 (define-default-presentation-method accept-present-default
386 (type stream (view text-field-view) default default-supplied-p
387 present-p query-identifier)
388 (if (width view)
389 (multiple-value-bind (cx cy)
390 (stream-cursor-position stream)
391 (declare (ignore cy))
392 (letf (((stream-text-margin stream) (+ cx (width view))))
393 (funcall-presentation-generic-function accept-present-default
394 type
395 stream
396 +textual-dialog-view+
397 default default-supplied-p
398 present-p
399 query-identifier)))))
400
401 (define-default-presentation-method accept-present-default
402 (type stream (view textual-dialog-view) default default-supplied-p
403 present-p query-identifier)
404 (declare (ignore present-p))
405 (let* ((editing-stream nil)
406 (record (updating-output (stream :unique-id query-identifier
407 :cache-value (if default-supplied-p
408 default
409 *no-default-cache-value*)
410 :record-type 'av-text-record)
411 (with-output-as-presentation
412 (stream query-identifier 'selectable-query)
413 (surrounding-output-with-border
414 (stream :shape :inset :move-cursor t)
415 (setq editing-stream
416 (make-instance 'standard-input-editing-stream
417 :stream stream
418 :cursor-visibility nil
419 :background-ink +grey90+
420 :single-line t))))
421 (when default-supplied-p
422 (input-editing-rescan-loop ;XXX probably not needed
423 editing-stream
424 (lambda (s)
425 (presentation-replace-input s default type view
426 :rescan t)
427 (goatee::update-input-editing-stream s)))))))
428 (when editing-stream
429 (setf (editing-stream record) editing-stream))
430 record))
431
432 (defun av-do-accept (query record)
433 (let ((estream (editing-stream record))
434 (ptype (ptype query))
435 (view (view query))
436 (default (default query))
437 (default-supplied-p (default-supplied-p query)))
438 (setf (values (value query) (ptype query)) ; Hmm, should ptype be set here?
439 (input-editing-rescan-loop
440 estream
441 (if default-supplied-p
442 ;; Allow empty input to return a default value
443 #'(lambda (s)
444 (accept ptype :stream s :view view :prompt nil
445 :default default))
446 #'(lambda (s)
447 (accept ptype :stream s :view view :prompt nil)))))
448 (setf (changedp query) t)))
449
450
451
452 ;;; The desired
453 (defmethod select-query (stream query (record av-text-record))
454 (declare (ignore stream))
455 (let ((estream (editing-stream record))
456 (ptype (ptype query))
457 (view (view query))
458 (accept-args (accept-arguments query)))
459 (declare (ignore ptype view)) ;for now
460 (let* ((*activation-gestures* (apply #'make-activation-gestures
461 :existing-activation-gestures
462 (activation-gestures query)
463 accept-args))
464
465 (*delimiter-gestures* (apply #'make-delimiter-gestures
466 :existing-delimiter-args
467 (delimiter-gestures query)
468 accept-args)))
469 (with-accessors ((stream-activated stream-activated)
470 (stream-input-buffer stream-input-buffer))
471 estream
472 ;; "deactivate" editing stream if user has previously activated it.
473 (when stream-activated
474 (setf stream-activated nil)
475 (when (activation-gesture-p (aref stream-input-buffer
476 (1- (fill-pointer
477 stream-input-buffer))))
478 (replace-input estream ""
479 :buffer-start (1- (fill-pointer
480 stream-input-buffer))
481 :rescan t)))
482 (setf (cursor-visibility estream) t)
483 (setf (snapshot record) (copy-seq stream-input-buffer))
484 (block accept-condition-handler
485 (handler-bind ((condition #'(lambda (c)
486 (format *trace-output*
487 "accepting-values accept condition: ~A~%"
488 c)
489 (setf (accept-condition query) c)
490 (return-from accept-condition-handler
491 c))))
492 (av-do-accept query record)))))))
493
494
495
496 (defmethod deselect-query (stream query (record av-text-record))
497 (let ((estream (editing-stream record)))
498 (setf (cursor-visibility estream) nil)))
499
500 (defgeneric finalize-query-record (query record)
501 (:documentation "Do any cleanup on a query before the accepting-values body
502 is run for the last time"))
503
504 (defmethod finalize-query-record (query record)
505 nil)
506
507 ;;; If the user edits a text field, selects another text field and
508 ;;; then exits from accepting-values without activating the first
509 ;;; field, the values returned would be some previous value or default
510 ;;; for the field, not what's on the screen. That would be completely
511 ;;; bogus. So, if a field has been edited but not activated, activate
512 ;;; it now. Unfortunately that's a bit hairy.
513
514 (defmethod finalize-query-record (query (record av-text-record))
515 (let ((estream (editing-stream record)))
516 (when (and (not (stream-activated estream))
517 (snapshot record)
518 (not (equal (snapshot record)
519 (stream-input-buffer estream))))
520 (let* ((activation-gestures (apply #'make-activation-gestures
521 :existing-activation-gestures
522 (activation-gestures query)
523 (accept-arguments query)))
524 (gesture (car activation-gestures)))
525 (when gesture
526 (let ((c (character-gesture-name gesture)))
527 (replace-input estream (string c)
528 :buffer-start (fill-pointer (stream-input-buffer
529 estream))
530 :rescan nil)
531 (setf (stream-activated estream) t)
532 (reset-scan-pointer estream)
533 (av-do-accept query record)))))))
534
535 (defun finalize-query-records (av-stream)
536 (loop for query in (queries av-stream)
537 do (finalize-query-record query (record query))))
538
539
540 (define-presentation-to-command-translator com-select-field
541 (selectable-query com-select-query accepting-values
542 :gesture :select
543 :documentation "Select field for input"
544 :pointer-documentation "Select field for input"
545 :echo nil
546 :tester ((object)
547 (let ((selected (selected-query *accepting-values-stream*)))
548 (or (null selected)
549 (not (eq (query-identifier selected) object))))))
550 (object)
551 `(,object))
552
553 (define-presentation-to-command-translator com-exit-button
554 (exit-button com-query-exit accepting-values
555 :gesture :select
556 :documentation "Exit dialog"
557 :pointer-documentation "Exit dialog"
558 :echo nil)
559 ()
560 ())
561
562 (define-presentation-to-command-translator com-abort-button
563 (abort-button com-query-abort accepting-values
564 :gesture :select
565 :documentation "Abort dialog"
566 :pointer-documentation "Abort dialog"
567 :echo nil)
568 ()
569 ())
570
571 (defun accepting-values-default-command ()
572 (loop
573 (read-gesture :stream *accepting-values-stream*)))

  ViewVC Help
Powered by ViewVC 1.1.5