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

Contents of /mcclim/dialog.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.7 - (show annotations)
Wed Jul 16 17:27:46 2003 UTC (10 years, 9 months ago) by moore
Branch: MAIN
CVS Tags: McCLIM-0-9
Changes since 1.6: +6 -5 lines
Don't define an accessor with a reserved name in Common Lisp, per Paul Werkowski
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 (value :accessor value :initarg :value :initform nil)
47 (changedp :accessor changedp :initform nil)
48 (record :accessor record :initarg :record)
49 (activation-gestures :accessor activation-gestures
50 :initform *activation-gestures*
51 :documentation "Binding of *activation-gestures* on
52 entry to this accept")
53 (delimeter-gestures :accessor delimiter-gestures
54 :initform *delimiter-gestures*
55 :documentation "Binding of *delimeter-gestures* on entry
56 to this accept")
57 (accept-arguments :accessor accept-arguments :initarg :accept-arguments)
58 (accept-condition :accessor accept-condition :initarg :accept-condition
59 :initform nil
60 :documentation "Condition signalled, if any, during
61 accept of this query")))
62
63 (defclass accepting-values-record (standard-updating-output-record)
64 ())
65
66 (defclass accepting-values-stream (standard-encapsulating-stream)
67 ((queries :accessor queries :initform nil)
68 (selected-query :accessor selected-query :initform nil)))
69
70 (defmethod stream-default-view ((stream accepting-values-stream))
71 +textual-dialog-view+)
72
73 (define-condition av-exit (condition)
74 ())
75
76 ;;; The accepting-values state machine is controlled by commands. Each
77 ;;; action (e.g., "select a text field") terminates
78
79 (define-command-table accepting-values) ; :inherit-from nil???
80
81 (defvar *default-command* '(accepting-values-default-command))
82
83 ;;; The fields of the query have presentation type query. Fields that
84 ;;; are "selectable", like the default text editor field, have type
85 ;;; selectable-query. The presentation object is the query
86 ;;; identifier.
87
88 (define-presentation-type query () :inherit-from t)
89
90 (define-presentation-type selectable-query () :inherit-from 'query)
91
92 (define-presentation-type exit-button () :inherit-from t)
93
94 (define-presentation-type abort-button () :inherit-from t)
95
96 (defvar *accepting-values-stream* nil)
97
98 (defmacro accepting-values
99 ((&optional (stream t)
100 &rest args
101 &key own-window exit-boxes initially-select-query-identifier
102 modify-initial-query resynchronize-every-pass resize-frame
103 align-prompts label scroll-bars
104 x-position y-position width height command-table frame-class)
105 &body body)
106 (declare (ignorable own-window exit-boxes initially-select-query-identifier
107 modify-initial-query resynchronize-every-pass resize-frame
108 align-prompts label scroll-bars
109 x-position y-position width height command-table frame-class))
110 (when (eq stream 't)
111 (setq stream '*standard-input*))
112 (check-type stream symbol)
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 (apply #'prompt-for-accept stream type view rest-args)
201 (let ((query (find query-identifier (queries stream)
202 :key #'query-identifier :test #'equal)))
203 (unless query
204 (setq query (make-instance 'query
205 :query-identifier query-identifier
206 :ptype type
207 :view view
208 :default default
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 :name nil)
238 ()
239 (signal 'av-exit))
240
241 (define-command (com-query-abort :command-table accepting-values :name nil)
242 ()
243 (and (find-restart 'abort)
244 (invoke-restart 'abort)))
245
246 (define-command (com-change-query :command-table accepting-values :name nil)
247 ((query-identifier t)
248 (value t))
249 (when *accepting-values-stream*
250 (let ((query (find query-identifier (queries *accepting-values-stream*)
251 :key #'query-identifier :test #'equal)))
252 (when query
253 (setf (value query) value)
254 (setf (changedp query) t)))))
255
256 (defgeneric select-query (stream query record)
257 (:documentation "Does whatever is needed for input (e.g., calls accept) when
258 a query is selected for input." ))
259
260 (defgeneric deselect-query (stream query record)
261 (:documentation "Deselect a query field: turn the cursor off, turn off
262 highlighting, etc." ))
263
264 (define-command (com-select-query :command-table accepting-values :name nil)
265 ((query-identifier t))
266 (when *accepting-values-stream*
267 (with-accessors ((selected-query selected-query))
268 *accepting-values-stream*
269 (let* ((query-list (member query-identifier
270 (queries *accepting-values-stream*)
271 :key #'query-identifier :test #'equal))
272 (query (car query-list)))
273 (when selected-query
274 (unless (equal query-identifier
275 (query-identifier selected-query))
276 (deselect-query *accepting-values-stream*
277 selected-query
278 (record selected-query))))
279 (when query
280 (setf selected-query query)
281 (select-query *accepting-values-stream* query (record query))
282 (if (cdr query-list)
283 (throw-object-ptype (query-identifier (cadr query-list))
284 'selectable-query)
285 (throw-object-ptype '(com-deselect-query)
286 '(command :command-table accepting-values))))))))
287
288 (define-command (com-deselect-query :command-table accepting-values :name nil)
289 ()
290 (when *accepting-values-stream*
291 (with-accessors ((selected-query selected-query))
292 *accepting-values-stream*
293 (when selected-query
294 (deselect-query *accepting-values-stream*
295 selected-query
296 (record selected-query))
297 (setf selected-query nil)))))
298
299 (defclass av-text-record (standard-updating-output-record)
300 ((editing-stream :accessor editing-stream)
301 (snapshot :accessor snapshot :initarg :snapshot :initform nil
302 :documentation "A copy of the stream buffer before accept
303 is called. Used to determine if any editing has been done by user")))
304
305 (define-default-presentation-method accept-present-default
306 (type stream (view textual-dialog-view) default default-supplied-p
307 present-p query-identifier)
308 (let* ((editing-stream nil)
309 (record (updating-output (stream :unique-id query-identifier
310 :cache-value query-identifier
311 :record-type 'av-text-record)
312 (with-output-as-presentation
313 (stream query-identifier 'selectable-query)
314 (setq editing-stream
315 (make-instance 'standard-input-editing-stream
316 :stream stream
317 :cursor-visibility nil
318 :background-ink +grey90+))))))
319 (when editing-stream
320 (setf (editing-stream record) editing-stream))
321 record))
322
323 (defun av-do-accept (query record)
324 (let ((estream (editing-stream record))
325 (ptype (ptype query))
326 (view (view query)))
327 (setf (values (value query) (ptype query)) ; Hmm, should ptype be set here?
328 (input-editing-rescan-loop
329 estream
330 #'(lambda (s)
331 (accept ptype :stream s :view view :prompt nil))))))
332
333
334 ;;; The desired
335 (defmethod select-query (stream query (record av-text-record))
336 (declare (ignore stream))
337 (let ((estream (editing-stream record))
338 (ptype (ptype query))
339 (view (view query))
340 (accept-args (accept-arguments query)))
341 (declare (ignore ptype view)) ;for now
342 (let* ((*activation-gestures* (apply #'make-activation-gestures
343 :existing-activation-gestures
344 (activation-gestures query)
345 accept-args))
346
347 (*delimiter-gestures* (apply #'make-delimiter-gestures
348 :existing-delimiter-args
349 (delimiter-gestures query)
350 accept-args)))
351 (with-accessors ((stream-activated stream-activated)
352 (stream-input-buffer stream-input-buffer))
353 estream
354 ;; "deactivate" editing stream if user has previously activated it.
355 (when stream-activated
356 (setf stream-activated nil)
357 (when (activation-gesture-p (aref stream-input-buffer
358 (1- (fill-pointer
359 stream-input-buffer))))
360 (replace-input estream ""
361 :buffer-start (1- (fill-pointer
362 stream-input-buffer))
363 :rescan t)))
364 (setf (cursor-visibility estream) t)
365 (setf (snapshot record) (copy-seq stream-input-buffer))
366 (handler-case
367 (av-do-accept query record)
368 (condition (c)
369 (setf (accept-condition query) c)))))))
370
371
372 (defmethod deselect-query (stream query (record av-text-record))
373 (let ((estream (editing-stream record)))
374 (setf (cursor-visibility estream) nil)))
375
376 (defgeneric finalize-query-record (query record)
377 (:documentation "Do any cleanup on a query before the accepting-values body
378 is run for the last time"))
379
380 (defmethod finalize-query-record (query record)
381 nil)
382
383 ;;; If the user edits a text field, selects another text field and
384 ;;; then exits from accepting-values without activating the first
385 ;;; field, the values returned would be some previous value or default
386 ;;; for the field, not what's on the screen. That would be completely
387 ;;; bogus. So, if a field has been edited but not activated, activate
388 ;;; it now. Unfortunately that's a bit hairy.
389
390 (defmethod finalize-query-record (query (record av-text-record))
391 (let ((estream (editing-stream record)))
392 (when (and (not (stream-activated estream))
393 (snapshot record)
394 (not (equal (snapshot record)
395 (stream-input-buffer estream))))
396 (let* ((activation-gestures (apply #'make-activation-gestures
397 :existing-activation-gestures
398 (activation-gestures query)
399 (accept-arguments query)))
400 (gesture (car activation-gestures)))
401 (when gesture
402 (let ((c (character-gesture-name gesture)))
403 (replace-input estream (string c)
404 :buffer-start (fill-pointer (stream-input-buffer
405 estream))
406 :rescan nil)
407 (setf (stream-activated estream) t)
408 (reset-scan-pointer estream)
409 (av-do-accept query record)))))))
410
411 (defun finalize-query-records (av-stream)
412 (loop for query in (queries av-stream)
413 do (finalize-query-record query (record query))))
414
415
416 (define-presentation-to-command-translator com-select-field
417 (selectable-query com-select-query accepting-values
418 :gesture :select
419 :documentation "Select field for input"
420 :pointer-documentation "Select field for input"
421 :echo nil
422 :tester ((object)
423 (let ((selected (selected-query *accepting-values-stream*)))
424 (or (null selected)
425 (not (eq (query-identifier selected) object))))))
426 (object)
427 `(,object))
428
429 (define-presentation-to-command-translator com-exit-button
430 (exit-button com-query-exit accepting-values
431 :gesture :select
432 :documentation "Exit dialog"
433 :pointer-documentation "Exit dialog"
434 :echo nil)
435 ()
436 ())
437
438 (define-presentation-to-command-translator com-abort-button
439 (abort-button com-query-abort accepting-values
440 :gesture :select
441 :documentation "Abort dialog"
442 :pointer-documentation "Abort dialog"
443 :echo nil)
444 ()
445 ())
446
447 (defun accepting-values-default-command ()
448 (loop
449 (read-gesture :stream *accepting-values-stream*)))

  ViewVC Help
Powered by ViewVC 1.1.5