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

Contents of /mcclim/dialog.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.10 - (show annotations)
Tue Jan 20 16:07:25 2004 UTC (10 years, 3 months ago) by moore
Branch: MAIN
Changes since 1.9: +0 -1 lines
Presentation histories. The new goatee command C-M y works reasonably
well in the listener demo. More testing and user documentation is needed.

Work in progress on the OpenGL backend.
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 (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 :value default))
209 (setf (queries stream) (nconc (queries stream) (list query))))
210 (setf (accept-arguments query) rest-args)
211 ;; If the program changes the default, that becomes the value.
212 (unless (equal default (default query))
213 (setf (default query) default)
214 (setf (value query) default))
215 (let ((query-record (funcall-presentation-generic-function
216 accept-present-default
217 type (encapsulating-stream-stream stream) view
218 (value query)
219 default-supplied-p
220 nil query-identifier)))
221 (setf (record query) query-record)
222 (when (accept-condition query)
223 (signal (accept-condition query)))
224 (multiple-value-prog1
225 (values (value query) (ptype query) (changedp query))
226 (setf (default query) default)
227 (setf (ptype query) type)
228 (setf (changedp query) nil)))))
229
230 (defmethod prompt-for-accept ((stream accepting-values-stream)
231 type view
232 &rest args)
233 (declare (ignore view))
234 (apply #'prompt-for-accept-1 stream type :display-default nil args))
235
236 (define-command (com-query-exit :command-table accepting-values :name nil)
237 ()
238 (signal 'av-exit))
239
240 (define-command (com-query-abort :command-table accepting-values :name nil)
241 ()
242 (and (find-restart 'abort)
243 (invoke-restart 'abort)))
244
245 (define-command (com-change-query :command-table accepting-values :name nil)
246 ((query-identifier t)
247 (value t))
248 (when *accepting-values-stream*
249 (let ((query (find query-identifier (queries *accepting-values-stream*)
250 :key #'query-identifier :test #'equal)))
251 (when query
252 (setf (value query) value)
253 (setf (changedp query) t)))))
254
255 (defgeneric select-query (stream query record)
256 (:documentation "Does whatever is needed for input (e.g., calls accept) when
257 a query is selected for input." ))
258
259 (defgeneric deselect-query (stream query record)
260 (:documentation "Deselect a query field: turn the cursor off, turn off
261 highlighting, etc." ))
262
263 (define-command (com-select-query :command-table accepting-values :name nil)
264 ((query-identifier t))
265 (when *accepting-values-stream*
266 (with-accessors ((selected-query selected-query))
267 *accepting-values-stream*
268 (let* ((query-list (member query-identifier
269 (queries *accepting-values-stream*)
270 :key #'query-identifier :test #'equal))
271 (query (car query-list)))
272 (when selected-query
273 (unless (equal query-identifier
274 (query-identifier selected-query))
275 (deselect-query *accepting-values-stream*
276 selected-query
277 (record selected-query))))
278 (when query
279 (setf selected-query query)
280 (select-query *accepting-values-stream* query (record query))
281 (if (cdr query-list)
282 (throw-object-ptype (query-identifier (cadr query-list))
283 'selectable-query)
284 (throw-object-ptype '(com-deselect-query)
285 '(command :command-table accepting-values))))))))
286
287 (define-command (com-deselect-query :command-table accepting-values :name nil)
288 ()
289 (when *accepting-values-stream*
290 (with-accessors ((selected-query selected-query))
291 *accepting-values-stream*
292 (when selected-query
293 (deselect-query *accepting-values-stream*
294 selected-query
295 (record selected-query))
296 (setf selected-query nil)))))
297
298 (defclass av-text-record (standard-updating-output-record)
299 ((editing-stream :accessor editing-stream)
300 (snapshot :accessor snapshot :initarg :snapshot :initform nil
301 :documentation "A copy of the stream buffer before accept
302 is called. Used to determine if any editing has been done by user")))
303
304 (define-default-presentation-method accept-present-default
305 (type stream (view textual-dialog-view) default default-supplied-p
306 present-p query-identifier)
307 (let* ((editing-stream nil)
308 (record (updating-output (stream :unique-id query-identifier
309 :cache-value query-identifier
310 :record-type 'av-text-record)
311 (with-output-as-presentation
312 (stream query-identifier 'selectable-query)
313 (surrounding-output-with-border
314 (stream :shape :drop-shadow :move-cursor t)
315 (setq editing-stream
316 (make-instance 'standard-input-editing-stream
317 :stream stream
318 :cursor-visibility nil
319 :background-ink +grey90+))))
320 (when default-supplied-p
321 (input-editing-rescan-loop ;XXX probably not needed
322 editing-stream
323 (lambda (s)
324 (presentation-replace-input s default type view
325 :rescan t)
326 (goatee::update-input-editing-stream s)))))))
327 (when editing-stream
328 (setf (editing-stream record) editing-stream))
329 record))
330
331 (defun av-do-accept (query record)
332 (let ((estream (editing-stream record))
333 (ptype (ptype query))
334 (view (view query)))
335 (setf (values (value query) (ptype query)) ; Hmm, should ptype be set here?
336 (input-editing-rescan-loop
337 estream
338 #'(lambda (s)
339 (accept ptype :stream s :view view :prompt nil))))))
340
341
342 ;;; The desired
343 (defmethod select-query (stream query (record av-text-record))
344 (declare (ignore stream))
345 (let ((estream (editing-stream record))
346 (ptype (ptype query))
347 (view (view query))
348 (accept-args (accept-arguments query)))
349 (declare (ignore ptype view)) ;for now
350 (let* ((*activation-gestures* (apply #'make-activation-gestures
351 :existing-activation-gestures
352 (activation-gestures query)
353 accept-args))
354
355 (*delimiter-gestures* (apply #'make-delimiter-gestures
356 :existing-delimiter-args
357 (delimiter-gestures query)
358 accept-args)))
359 (with-accessors ((stream-activated stream-activated)
360 (stream-input-buffer stream-input-buffer))
361 estream
362 ;; "deactivate" editing stream if user has previously activated it.
363 (when stream-activated
364 (setf stream-activated nil)
365 (when (activation-gesture-p (aref stream-input-buffer
366 (1- (fill-pointer
367 stream-input-buffer))))
368 (replace-input estream ""
369 :buffer-start (1- (fill-pointer
370 stream-input-buffer))
371 :rescan t)))
372 (setf (cursor-visibility estream) t)
373 (setf (snapshot record) (copy-seq stream-input-buffer))
374 (handler-case
375 (av-do-accept query record)
376 (condition (c)
377 (format *trace-output* "accepting-values accept condition: ~A~%"
378 c)
379 (setf (accept-condition query) c)))))))
380
381
382 (defmethod deselect-query (stream query (record av-text-record))
383 (let ((estream (editing-stream record)))
384 (setf (cursor-visibility estream) nil)))
385
386 (defgeneric finalize-query-record (query record)
387 (:documentation "Do any cleanup on a query before the accepting-values body
388 is run for the last time"))
389
390 (defmethod finalize-query-record (query record)
391 nil)
392
393 ;;; If the user edits a text field, selects another text field and
394 ;;; then exits from accepting-values without activating the first
395 ;;; field, the values returned would be some previous value or default
396 ;;; for the field, not what's on the screen. That would be completely
397 ;;; bogus. So, if a field has been edited but not activated, activate
398 ;;; it now. Unfortunately that's a bit hairy.
399
400 (defmethod finalize-query-record (query (record av-text-record))
401 (let ((estream (editing-stream record)))
402 (when (and (not (stream-activated estream))
403 (snapshot record)
404 (not (equal (snapshot record)
405 (stream-input-buffer estream))))
406 (let* ((activation-gestures (apply #'make-activation-gestures
407 :existing-activation-gestures
408 (activation-gestures query)
409 (accept-arguments query)))
410 (gesture (car activation-gestures)))
411 (when gesture
412 (let ((c (character-gesture-name gesture)))
413 (replace-input estream (string c)
414 :buffer-start (fill-pointer (stream-input-buffer
415 estream))
416 :rescan nil)
417 (setf (stream-activated estream) t)
418 (reset-scan-pointer estream)
419 (av-do-accept query record)))))))
420
421 (defun finalize-query-records (av-stream)
422 (loop for query in (queries av-stream)
423 do (finalize-query-record query (record query))))
424
425
426 (define-presentation-to-command-translator com-select-field
427 (selectable-query com-select-query accepting-values
428 :gesture :select
429 :documentation "Select field for input"
430 :pointer-documentation "Select field for input"
431 :echo nil
432 :tester ((object)
433 (let ((selected (selected-query *accepting-values-stream*)))
434 (or (null selected)
435 (not (eq (query-identifier selected) object))))))
436 (object)
437 `(,object))
438
439 (define-presentation-to-command-translator com-exit-button
440 (exit-button com-query-exit accepting-values
441 :gesture :select
442 :documentation "Exit dialog"
443 :pointer-documentation "Exit dialog"
444 :echo nil)
445 ()
446 ())
447
448 (define-presentation-to-command-translator com-abort-button
449 (abort-button com-query-abort accepting-values
450 :gesture :select
451 :documentation "Abort dialog"
452 :pointer-documentation "Abort dialog"
453 :echo nil)
454 ()
455 ())
456
457 (defun accepting-values-default-command ()
458 (loop
459 (read-gesture :stream *accepting-values-stream*)))

  ViewVC Help
Powered by ViewVC 1.1.5