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

Contents of /mcclim/dialog.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.13 - (hide annotations)
Fri Oct 15 13:05:36 2004 UTC (9 years, 6 months ago) by moore
Branch: MAIN
Changes since 1.12: +16 -6 lines
Implement the :INITIALLY-SELECT-QUERY-IDENTIFIER option of
ACCEPTING-VALUES. Update the text entry field in ACCEPTING-VALUES
when the :DEFAULT argument in the corresponding call to ACCEPT
changes. Return the correct third value from ACCEPT when the user
enters new input.

Add some documentation about INCREMENTAL-DISPLAY and the difference
set.

Added FIND-PRESENTATION-TYPE-CLASS and CLASS-PRESENTATION-TYPE-NAME
which are trivial but which were not implemented.

Examples/accepting-values.lisp is a couple of examples from the Franz
user guide.

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

  ViewVC Help
Powered by ViewVC 1.1.5