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

Contents of /mcclim/dialog.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.12 - (show annotations)
Wed Oct 6 12:03:56 2004 UTC (9 years, 6 months ago) by moore
Branch: MAIN
Changes since 1.11: +19 -7 lines
Changed STREAM-DESIGNATOR-SYMBOL to take a default value
argument. The value corresponding to T isn't always *STANDARD-OUTPUT*.

Fixed a problem in the incremental redisplay code checked in
recently: the output record that holds an updating output record's
children wasn't always created.

Some tweaks (in progress) to 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.
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
72 (defmethod stream-default-view ((stream accepting-values-stream))
73 +textual-dialog-view+)
74
75 (define-condition av-exit (condition)
76 ())
77
78 ;;; The accepting-values state machine is controlled by commands. Each
79 ;;; action (e.g., "select a text field") terminates
80
81 (define-command-table accepting-values) ; :inherit-from nil???
82
83 (defvar *default-command* '(accepting-values-default-command))
84
85 ;;; The fields of the query have presentation type query. Fields that
86 ;;; are "selectable", like the default text editor field, have type
87 ;;; selectable-query. The presentation object is the query
88 ;;; identifier.
89
90 (define-presentation-type query () :inherit-from t)
91
92 (define-presentation-type selectable-query () :inherit-from 'query)
93
94 (define-presentation-type exit-button () :inherit-from t)
95
96 (define-presentation-type abort-button () :inherit-from t)
97
98 (defvar *accepting-values-stream* nil)
99
100 (defmacro accepting-values
101 ((&optional (stream t)
102 &rest args
103 &key own-window exit-boxes initially-select-query-identifier
104 modify-initial-query resynchronize-every-pass resize-frame
105 align-prompts label scroll-bars
106 x-position y-position width height command-table frame-class)
107 &body body)
108 (declare (ignorable own-window exit-boxes initially-select-query-identifier
109 modify-initial-query resynchronize-every-pass resize-frame
110 align-prompts label scroll-bars
111 x-position y-position width height command-table frame-class))
112 (setq stream (stream-designator-symbol stream '*standard-input*))
113 (with-gensyms (accepting-values-continuation)
114 `(flet ((,accepting-values-continuation (,stream)
115 ,@body))
116 (invoke-accepting-values ,stream
117 #',accepting-values-continuation
118 ,@args))))
119
120 (defun invoke-accepting-values
121 (stream body
122 &key own-window exit-boxes initially-select-query-identifier
123 modify-initial-query resynchronize-every-pass resize-frame
124 align-prompts label scroll-bars
125 x-position y-position width height
126 (command-table 'accepting-values)
127 (frame-class 'accept-values))
128 (let* ((*accepting-values-stream* (make-instance 'accepting-values-stream
129 :stream stream))
130 (arecord (updating-output (stream
131 :record-type 'accepting-values-record)
132 (funcall body *accepting-values-stream*)
133 (display-exit-boxes *application-frame*
134 stream
135 (stream-default-view
136 *accepting-values-stream*))))
137 (first-time t)
138 (current-command *default-command*))
139 (letf (((frame-command-table *application-frame*)
140 (find-command-table command-table)))
141 (unwind-protect
142 (handler-case
143 (loop
144 (if first-time
145 (setq first-time nil)
146 (when resynchronize-every-pass
147 (redisplay arecord stream)))
148 (with-input-context
149 ('(command :command-table accepting-values))
150 (object)
151 (progn
152 (apply (command-name current-command)
153 (command-arguments current-command))
154 ;; If current command returns without throwing a
155 ;; command, go back to the default command
156 (setq current-command *default-command*))
157 (t (setq current-command object)))
158 (redisplay arecord stream))
159 (av-exit ()
160 (finalize-query-records *accepting-values-stream*)
161 (redisplay arecord stream)))
162 (erase-output-record arecord stream)))))
163
164 (defgeneric display-exit-boxes (frame stream view))
165
166 (defmethod display-exit-boxes (frame stream (view textual-dialog-view))
167 (declare (ignore frame))
168 (updating-output (stream :unique-id 'buttons :cache-value t)
169 (fresh-line stream)
170 (with-output-as-presentation
171 (stream nil 'exit-button)
172 (format stream "Exit"))
173 (write-char #\space stream)
174 (with-output-as-presentation
175 (stream nil 'abort-button)
176 (format stream "Abort"))
177 (terpri stream)))
178
179 (defmethod stream-accept ((stream accepting-values-stream) type
180 &rest rest-args
181 &key
182 (view (stream-default-view stream))
183 (default nil default-supplied-p)
184 default-type
185 provide-default
186 insert-default
187 replace-input
188 history
189 active-p
190 prompt
191 prompt-mode
192 display-default
193 (query-identifier prompt)
194 activation-gestures
195 additional-activation-gestures
196 delimiter-gestures
197 additional-delimiter-gestures)
198 (declare (ignore activation-gestures additional-activation-gestures
199 delimiter-gestures additional-delimiter-gestures))
200 (let ((query (find query-identifier (queries stream)
201 :key #'query-identifier :test #'equal)))
202 (unless query
203 (setq query (make-instance 'query
204 :query-identifier query-identifier
205 :ptype type
206 :view view
207 :default default
208 :default-supplied-p default-supplied-p
209 :value default))
210 (setf (queries stream) (nconc (queries stream) (list query))))
211 (setf (accept-arguments query) rest-args)
212 ;; If the program changes the default, that becomes the value.
213 (unless (equal default (default query))
214 (setf (default query) default)
215 (setf (value query) default))
216 (let ((query-record (funcall-presentation-generic-function
217 accept-present-default
218 type (encapsulating-stream-stream stream) view
219 (value query)
220 default-supplied-p
221 nil query-identifier)))
222 (setf (record query) query-record)
223 (when (accept-condition query)
224 (signal (accept-condition query)))
225 (multiple-value-prog1
226 (values (value query) (ptype query) (changedp query))
227 (setf (default query) default)
228 (setf (ptype query) type)
229 (setf (changedp query) nil)))))
230
231 (defmethod prompt-for-accept ((stream accepting-values-stream)
232 type view
233 &rest args)
234 (declare (ignore view))
235 (apply #'prompt-for-accept-1 stream type :display-default nil args))
236
237 (define-command (com-query-exit :command-table accepting-values
238 :name nil
239 :provide-output-destination-keyword nil)
240 ()
241 (signal 'av-exit))
242
243 (define-command (com-query-abort :command-table accepting-values
244 :name nil
245 :provide-output-destination-keyword nil)
246 ()
247 (and (find-restart 'abort)
248 (invoke-restart 'abort)))
249
250 (define-command (com-change-query :command-table accepting-values
251 :name nil
252 :provide-output-destination-keyword nil)
253 ((query-identifier t)
254 (value t))
255 (when *accepting-values-stream*
256 (let ((query (find query-identifier (queries *accepting-values-stream*)
257 :key #'query-identifier :test #'equal)))
258 (when query
259 (setf (value query) value)
260 (setf (changedp query) t)))))
261
262 (defgeneric select-query (stream query record)
263 (:documentation "Does whatever is needed for input (e.g., calls accept) when
264 a query is selected for input." ))
265
266 (defgeneric deselect-query (stream query record)
267 (:documentation "Deselect a query field: turn the cursor off, turn off
268 highlighting, etc." ))
269
270 (define-command (com-select-query :command-table accepting-values
271 :name nil
272 :provide-output-destination-keyword nil)
273 ((query-identifier t))
274 (when *accepting-values-stream*
275 (with-accessors ((selected-query selected-query))
276 *accepting-values-stream*
277 (let* ((query-list (member query-identifier
278 (queries *accepting-values-stream*)
279 :key #'query-identifier :test #'equal))
280 (query (car query-list)))
281 (when selected-query
282 (unless (equal query-identifier
283 (query-identifier selected-query))
284 (deselect-query *accepting-values-stream*
285 selected-query
286 (record selected-query))))
287 (when query
288 (setf selected-query query)
289 (select-query *accepting-values-stream* query (record query))
290 (if (cdr query-list)
291 (throw-object-ptype (query-identifier (cadr query-list))
292 'selectable-query)
293 (throw-object-ptype '(com-deselect-query)
294 '(command :command-table accepting-values))))))))
295
296 (define-command (com-deselect-query :command-table accepting-values
297 :name nil
298 :provide-output-destination-keyword nil)
299 ()
300 (when *accepting-values-stream*
301 (with-accessors ((selected-query selected-query))
302 *accepting-values-stream*
303 (when selected-query
304 (deselect-query *accepting-values-stream*
305 selected-query
306 (record selected-query))
307 (setf selected-query nil)))))
308
309 (defclass av-text-record (standard-updating-output-record)
310 ((editing-stream :accessor editing-stream)
311 (snapshot :accessor snapshot :initarg :snapshot :initform nil
312 :documentation "A copy of the stream buffer before accept
313 is called. Used to determine if any editing has been done by user")))
314
315 (define-default-presentation-method accept-present-default
316 (type stream (view textual-dialog-view) default default-supplied-p
317 present-p query-identifier)
318 (declare (ignore present-p))
319 (let* ((editing-stream nil)
320 ;; XXX Should be :CACHE-VALUE DEFAULT, but Goatee areas
321 ;; aren't playing nicely with updating-output yet.
322 (record (updating-output (stream :unique-id query-identifier
323 :cache-value t
324 :record-type 'av-text-record)
325 (with-output-as-presentation
326 (stream query-identifier 'selectable-query)
327 (surrounding-output-with-border
328 (stream :shape :drop-shadow :move-cursor t)
329 (setq editing-stream
330 (make-instance 'standard-input-editing-stream
331 :stream stream
332 :cursor-visibility nil
333 :background-ink +grey90+))))
334 (when default-supplied-p
335 (input-editing-rescan-loop ;XXX probably not needed
336 editing-stream
337 (lambda (s)
338 (presentation-replace-input s default type view
339 :rescan t)
340 (goatee::update-input-editing-stream s)))))))
341 (when editing-stream
342 (setf (editing-stream record) editing-stream))
343 record))
344
345 (defun av-do-accept (query record)
346 (let ((estream (editing-stream record))
347 (ptype (ptype query))
348 (view (view query))
349 (default (default query))
350 (default-supplied-p (default-supplied-p query)))
351 (setf (values (value query) (ptype query)) ; Hmm, should ptype be set here?
352 (input-editing-rescan-loop
353 estream
354 (if default-supplied-p
355 ;; Allow empty input to return a default value
356 #'(lambda (s)
357 (accept ptype :stream s :view view :prompt nil
358 :default default))
359 #'(lambda (s)
360 (accept ptype :stream s :view view :prompt nil)))))))
361
362
363
364 ;;; The desired
365 (defmethod select-query (stream query (record av-text-record))
366 (declare (ignore stream))
367 (let ((estream (editing-stream record))
368 (ptype (ptype query))
369 (view (view query))
370 (accept-args (accept-arguments query)))
371 (declare (ignore ptype view)) ;for now
372 (let* ((*activation-gestures* (apply #'make-activation-gestures
373 :existing-activation-gestures
374 (activation-gestures query)
375 accept-args))
376
377 (*delimiter-gestures* (apply #'make-delimiter-gestures
378 :existing-delimiter-args
379 (delimiter-gestures query)
380 accept-args)))
381 (with-accessors ((stream-activated stream-activated)
382 (stream-input-buffer stream-input-buffer))
383 estream
384 ;; "deactivate" editing stream if user has previously activated it.
385 (when stream-activated
386 (setf stream-activated nil)
387 (when (activation-gesture-p (aref stream-input-buffer
388 (1- (fill-pointer
389 stream-input-buffer))))
390 (replace-input estream ""
391 :buffer-start (1- (fill-pointer
392 stream-input-buffer))
393 :rescan t)))
394 (setf (cursor-visibility estream) t)
395 (setf (snapshot record) (copy-seq stream-input-buffer))
396 (handler-case
397 (av-do-accept query record)
398 (condition (c)
399 (format *trace-output* "accepting-values accept condition: ~A~%"
400 c)
401 (setf (accept-condition query) c)))))))
402
403
404 (defmethod deselect-query (stream query (record av-text-record))
405 (let ((estream (editing-stream record)))
406 (setf (cursor-visibility estream) nil)))
407
408 (defgeneric finalize-query-record (query record)
409 (:documentation "Do any cleanup on a query before the accepting-values body
410 is run for the last time"))
411
412 (defmethod finalize-query-record (query record)
413 nil)
414
415 ;;; If the user edits a text field, selects another text field and
416 ;;; then exits from accepting-values without activating the first
417 ;;; field, the values returned would be some previous value or default
418 ;;; for the field, not what's on the screen. That would be completely
419 ;;; bogus. So, if a field has been edited but not activated, activate
420 ;;; it now. Unfortunately that's a bit hairy.
421
422 (defmethod finalize-query-record (query (record av-text-record))
423 (let ((estream (editing-stream record)))
424 (when (and (not (stream-activated estream))
425 (snapshot record)
426 (not (equal (snapshot record)
427 (stream-input-buffer estream))))
428 (let* ((activation-gestures (apply #'make-activation-gestures
429 :existing-activation-gestures
430 (activation-gestures query)
431 (accept-arguments query)))
432 (gesture (car activation-gestures)))
433 (when gesture
434 (let ((c (character-gesture-name gesture)))
435 (replace-input estream (string c)
436 :buffer-start (fill-pointer (stream-input-buffer
437 estream))
438 :rescan nil)
439 (setf (stream-activated estream) t)
440 (reset-scan-pointer estream)
441 (av-do-accept query record)))))))
442
443 (defun finalize-query-records (av-stream)
444 (loop for query in (queries av-stream)
445 do (finalize-query-record query (record query))))
446
447
448 (define-presentation-to-command-translator com-select-field
449 (selectable-query com-select-query accepting-values
450 :gesture :select
451 :documentation "Select field for input"
452 :pointer-documentation "Select field for input"
453 :echo nil
454 :tester ((object)
455 (let ((selected (selected-query *accepting-values-stream*)))
456 (or (null selected)
457 (not (eq (query-identifier selected) object))))))
458 (object)
459 `(,object))
460
461 (define-presentation-to-command-translator com-exit-button
462 (exit-button com-query-exit accepting-values
463 :gesture :select
464 :documentation "Exit dialog"
465 :pointer-documentation "Exit dialog"
466 :echo nil)
467 ()
468 ())
469
470 (define-presentation-to-command-translator com-abort-button
471 (abort-button com-query-abort accepting-values
472 :gesture :select
473 :documentation "Abort dialog"
474 :pointer-documentation "Abort dialog"
475 :echo nil)
476 ()
477 ())
478
479 (defun accepting-values-default-command ()
480 (loop
481 (read-gesture :stream *accepting-values-stream*)))

  ViewVC Help
Powered by ViewVC 1.1.5