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

Contents of /mcclim/dialog.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.18 - (hide annotations)
Tue Feb 22 14:00:10 2005 UTC (9 years, 1 month ago) by tmoore
Branch: MAIN
Changes since 1.17: +80 -66 lines
Fixed presentation highlighting to do the right thing in the
:SINGLE-BOX NIL case.

Fixed Goatee to not draw anything when drawing is not enabled for the
stream.

Changed input editing streams to never put activation gestures in the
input buffer. There is only one place to receive an activation
gesture: the end of the buffer. If the user types an activation
gesture, the insertion pointer is moved to the end of the buffer.

Fixed various problems with accepting-values. In particular, the
insertion pointer does not need to be left at the end of a field when
the user exits the dialog. Also, the behavior in the presence of
errors new: if an error occurs while the user is typing in an
accepting-values field, the bell is beeped and the insertion pointer
is positioned before the stream position where the error occured.
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 tmoore 1.17 invocation of accepting-values. The record created and returned by
27     accept-present-default must be a subclass of updating-output-record.
28 moore 1.5
29 tmoore 1.17 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 moore 1.5
49 tmoore 1.17 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 moore 1.5
70 moore 1.3 |#
71    
72 mikemac 1.2 (in-package :clim-internals)
73 adejneka 1.1
74 moore 1.5 (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 moore 1.12 (default-supplied-p :accessor default-supplied-p
80     :initarg :default-supplied-p :initform nil)
81 moore 1.5 (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 moore 1.7 (accept-condition :accessor accept-condition :initarg :accept-condition
94     :initform nil
95     :documentation "Condition signalled, if any, during
96 moore 1.5 accept of this query")))
97    
98 moore 1.3 (defclass accepting-values-record (standard-updating-output-record)
99     ())
100    
101     (defclass accepting-values-stream (standard-encapsulating-stream)
102 moore 1.5 ((queries :accessor queries :initform nil)
103 moore 1.14 (selected-query :accessor selected-query :initform nil)
104     (align-prompts :accessor align-prompts :initarg :align-prompts
105 tmoore 1.18 :initform nil)
106     (last-pass :accessor last-pass :initform nil
107     :documentation "Flag that indicates the last pass through the
108     body of ACCEPTING-VALUES, after the user has chosen to exit. This controls
109     when conditions will be signalled from calls to ACCEPT.")))
110 moore 1.5
111     (defmethod stream-default-view ((stream accepting-values-stream))
112     +textual-dialog-view+)
113    
114     (define-condition av-exit (condition)
115 moore 1.3 ())
116    
117 moore 1.5 ;;; The accepting-values state machine is controlled by commands. Each
118     ;;; action (e.g., "select a text field") terminates
119    
120     (define-command-table accepting-values) ; :inherit-from nil???
121    
122     (defvar *default-command* '(accepting-values-default-command))
123    
124     ;;; The fields of the query have presentation type query. Fields that
125     ;;; are "selectable", like the default text editor field, have type
126     ;;; selectable-query. The presentation object is the query
127     ;;; identifier.
128    
129     (define-presentation-type query () :inherit-from t)
130    
131     (define-presentation-type selectable-query () :inherit-from 'query)
132    
133     (define-presentation-type exit-button () :inherit-from t)
134    
135     (define-presentation-type abort-button () :inherit-from t)
136    
137     (defvar *accepting-values-stream* nil)
138    
139 adejneka 1.1 (defmacro accepting-values
140     ((&optional (stream t)
141     &rest args
142     &key own-window exit-boxes initially-select-query-identifier
143     modify-initial-query resynchronize-every-pass resize-frame
144     align-prompts label scroll-bars
145     x-position y-position width height command-table frame-class)
146     &body body)
147     (declare (ignorable own-window exit-boxes initially-select-query-identifier
148     modify-initial-query resynchronize-every-pass resize-frame
149     align-prompts label scroll-bars
150     x-position y-position width height command-table frame-class))
151 moore 1.12 (setq stream (stream-designator-symbol stream '*standard-input*))
152 adejneka 1.1 (with-gensyms (accepting-values-continuation)
153     `(flet ((,accepting-values-continuation (,stream)
154     ,@body))
155     (invoke-accepting-values ,stream
156     #',accepting-values-continuation
157     ,@args))))
158 moore 1.3
159     (defun invoke-accepting-values
160     (stream body
161 moore 1.13 &key own-window exit-boxes
162     (initially-select-query-identifier nil initially-select-p)
163 moore 1.3 modify-initial-query resynchronize-every-pass resize-frame
164     align-prompts label scroll-bars
165 moore 1.5 x-position y-position width height
166     (command-table 'accepting-values)
167 moore 1.3 (frame-class 'accept-values))
168 moore 1.13 (declare (ignore own-window exit-boxes modify-initial-query
169 moore 1.14 resize-frame label scroll-bars x-position y-position
170 ahefner 1.15 width height frame-class))
171     (multiple-value-bind (cx cy) (stream-cursor-position stream)
172     (let* ((*accepting-values-stream*
173     (make-instance 'accepting-values-stream
174     :stream stream
175     :align-prompts align-prompts))
176     (arecord (updating-output (stream
177     :record-type 'accepting-values-record)
178     (if align-prompts
179     (formatting-table (stream)
180     (funcall body *accepting-values-stream*))
181     (funcall body *accepting-values-stream*))
182     (display-exit-boxes *application-frame*
183     stream
184     (stream-default-view
185     *accepting-values-stream*))))
186     (first-time t)
187     (current-command (if initially-select-p
188     `(com-select-query
189     ,initially-select-query-identifier)
190     *default-command*)))
191     (letf (((frame-command-table *application-frame*)
192     (find-command-table command-table)))
193     (unwind-protect
194     (handler-case
195     (loop
196     (if first-time
197     (setq first-time nil)
198     (when resynchronize-every-pass
199     (redisplay arecord stream)))
200     (with-input-context
201     ('(command :command-table accepting-values))
202     (object)
203     (progn
204     (apply (command-name current-command)
205     (command-arguments current-command))
206     ;; If current command returns without throwing a
207     ;; command, go back to the default command
208     (setq current-command *default-command*))
209     (t (setq current-command object)))
210     (redisplay arecord stream))
211     (av-exit ()
212     (finalize-query-records *accepting-values-stream*)
213 tmoore 1.18 (setf (last-pass *accepting-values-stream*) t)
214 ahefner 1.15 (redisplay arecord stream)))
215     (erase-output-record arecord stream)
216     (setf (stream-cursor-position stream)
217     (values cx cy)))))))
218 moore 1.5
219     (defgeneric display-exit-boxes (frame stream view))
220    
221     (defmethod display-exit-boxes (frame stream (view textual-dialog-view))
222     (declare (ignore frame))
223     (updating-output (stream :unique-id 'buttons :cache-value t)
224     (fresh-line stream)
225     (with-output-as-presentation
226     (stream nil 'exit-button)
227     (format stream "Exit"))
228     (write-char #\space stream)
229     (with-output-as-presentation
230     (stream nil 'abort-button)
231     (format stream "Abort"))
232     (terpri stream)))
233    
234     (defmethod stream-accept ((stream accepting-values-stream) type
235     &rest rest-args
236     &key
237     (view (stream-default-view stream))
238     (default nil default-supplied-p)
239     default-type
240     provide-default
241     insert-default
242     replace-input
243     history
244     active-p
245     prompt
246     prompt-mode
247     display-default
248     (query-identifier prompt)
249     activation-gestures
250     additional-activation-gestures
251     delimiter-gestures
252     additional-delimiter-gestures)
253     (declare (ignore activation-gestures additional-activation-gestures
254     delimiter-gestures additional-delimiter-gestures))
255     (let ((query (find query-identifier (queries stream)
256 moore 1.14 :key #'query-identifier :test #'equal))
257     (align (align-prompts stream)))
258 moore 1.5 (unless query
259     (setq query (make-instance 'query
260     :query-identifier query-identifier
261     :ptype type
262     :view view
263     :default default
264 moore 1.12 :default-supplied-p default-supplied-p
265 moore 1.5 :value default))
266     (setf (queries stream) (nconc (queries stream) (list query))))
267     (setf (accept-arguments query) rest-args)
268     ;; If the program changes the default, that becomes the value.
269     (unless (equal default (default query))
270     (setf (default query) default)
271     (setf (value query) default))
272 moore 1.14 (flet ((do-prompt ()
273     (apply #'prompt-for-accept stream type view rest-args))
274     (do-accept-present-default ()
275     (funcall-presentation-generic-function
276     accept-present-default
277     type (encapsulating-stream-stream stream) view
278     (value query)
279     default-supplied-p nil query-identifier)))
280     (let ((query-record nil))
281     (if align
282     (formatting-row (stream)
283     (formatting-cell (stream :align-x align)
284     (do-prompt))
285     (formatting-cell (stream)
286     (setq query-record (do-accept-present-default))))
287     (progn
288     (do-prompt)
289     (setq query-record (do-accept-present-default))))
290     (setf (record query) query-record)
291 tmoore 1.18 (when (and (last-pass stream) (accept-condition query))
292 moore 1.14 (signal (accept-condition query)))
293     (multiple-value-prog1
294     (values (value query) (ptype query) (changedp query))
295     (setf (default query) default)
296     (setf (ptype query) type)
297     (setf (changedp query) nil))))))
298    
299 moore 1.5
300     (defmethod prompt-for-accept ((stream accepting-values-stream)
301     type view
302     &rest args)
303     (declare (ignore view))
304     (apply #'prompt-for-accept-1 stream type :display-default nil args))
305    
306 moore 1.11 (define-command (com-query-exit :command-table accepting-values
307     :name nil
308     :provide-output-destination-keyword nil)
309 moore 1.5 ()
310     (signal 'av-exit))
311    
312 moore 1.11 (define-command (com-query-abort :command-table accepting-values
313     :name nil
314     :provide-output-destination-keyword nil)
315 moore 1.5 ()
316     (and (find-restart 'abort)
317     (invoke-restart 'abort)))
318    
319 moore 1.11 (define-command (com-change-query :command-table accepting-values
320     :name nil
321     :provide-output-destination-keyword nil)
322 moore 1.5 ((query-identifier t)
323     (value t))
324     (when *accepting-values-stream*
325     (let ((query (find query-identifier (queries *accepting-values-stream*)
326     :key #'query-identifier :test #'equal)))
327     (when query
328     (setf (value query) value)
329     (setf (changedp query) t)))))
330    
331     (defgeneric select-query (stream query record)
332     (:documentation "Does whatever is needed for input (e.g., calls accept) when
333 tmoore 1.17 a query is selected for input. It is responsible for updating the
334     query object when a new value is entered in the query field." ))
335 moore 1.5
336     (defgeneric deselect-query (stream query record)
337     (:documentation "Deselect a query field: turn the cursor off, turn off
338     highlighting, etc." ))
339 adejneka 1.1
340 moore 1.11 (define-command (com-select-query :command-table accepting-values
341     :name nil
342     :provide-output-destination-keyword nil)
343 moore 1.5 ((query-identifier t))
344     (when *accepting-values-stream*
345     (with-accessors ((selected-query selected-query))
346     *accepting-values-stream*
347     (let* ((query-list (member query-identifier
348     (queries *accepting-values-stream*)
349     :key #'query-identifier :test #'equal))
350     (query (car query-list)))
351     (when selected-query
352 tmoore 1.18 (unless (equal query-identifier (query-identifier selected-query))
353 moore 1.5 (deselect-query *accepting-values-stream*
354     selected-query
355     (record selected-query))))
356     (when query
357     (setf selected-query query)
358     (select-query *accepting-values-stream* query (record query))
359 tmoore 1.16 (let ((command-ptype '(command :command-table accepting-values)))
360     (if (cdr query-list)
361     (throw-object-ptype `(com-select-query ,(query-identifier
362     (cadr query-list)))
363     command-ptype)
364     (throw-object-ptype '(com-deselect-query) command-ptype))))))))
365 moore 1.5
366 moore 1.11 (define-command (com-deselect-query :command-table accepting-values
367     :name nil
368     :provide-output-destination-keyword nil)
369 moore 1.5 ()
370     (when *accepting-values-stream*
371     (with-accessors ((selected-query selected-query))
372     *accepting-values-stream*
373     (when selected-query
374     (deselect-query *accepting-values-stream*
375     selected-query
376     (record selected-query))
377     (setf selected-query nil)))))
378    
379     (defclass av-text-record (standard-updating-output-record)
380     ((editing-stream :accessor editing-stream)
381     (snapshot :accessor snapshot :initarg :snapshot :initform nil
382     :documentation "A copy of the stream buffer before accept
383     is called. Used to determine if any editing has been done by user")))
384    
385 moore 1.13 (defparameter *no-default-cache-value* (cons nil nil))
386 tmoore 1.16
387     ;;; Hack until more views / dialog gadgets are defined.
388    
389     (define-default-presentation-method accept-present-default
390     (type stream (view text-field-view) default default-supplied-p
391     present-p query-identifier)
392     (if (width view)
393     (multiple-value-bind (cx cy)
394     (stream-cursor-position stream)
395     (declare (ignore cy))
396     (letf (((stream-text-margin stream) (+ cx (width view))))
397     (funcall-presentation-generic-function accept-present-default
398     type
399     stream
400     +textual-dialog-view+
401     default default-supplied-p
402     present-p
403     query-identifier)))))
404 moore 1.13
405 moore 1.5 (define-default-presentation-method accept-present-default
406     (type stream (view textual-dialog-view) default default-supplied-p
407     present-p query-identifier)
408 moore 1.12 (declare (ignore present-p))
409 moore 1.5 (let* ((editing-stream nil)
410     (record (updating-output (stream :unique-id query-identifier
411 moore 1.13 :cache-value (if default-supplied-p
412     default
413     *no-default-cache-value*)
414 moore 1.5 :record-type 'av-text-record)
415     (with-output-as-presentation
416 tmoore 1.18 (stream query-identifier 'selectable-query
417     :single-box t)
418 moore 1.8 (surrounding-output-with-border
419 ahefner 1.15 (stream :shape :inset :move-cursor t)
420 moore 1.8 (setq editing-stream
421     (make-instance 'standard-input-editing-stream
422     :stream stream
423     :cursor-visibility nil
424 moore 1.14 :background-ink +grey90+
425     :single-line t))))
426 moore 1.9 (when default-supplied-p
427     (input-editing-rescan-loop ;XXX probably not needed
428     editing-stream
429     (lambda (s)
430     (presentation-replace-input s default type view
431     :rescan t)
432     (goatee::update-input-editing-stream s)))))))
433 moore 1.5 (when editing-stream
434     (setf (editing-stream record) editing-stream))
435     record))
436    
437 tmoore 1.18 (defun av-do-accept (query record interactive)
438     (let* ((estream (editing-stream record))
439     (ptype (ptype query))
440     (view (view query))
441     (default (default query))
442     (default-supplied-p (default-supplied-p query))
443     (accept-args (accept-arguments query))
444     (*activation-gestures* (apply #'make-activation-gestures
445     :existing-activation-gestures
446     (activation-gestures query)
447     accept-args))
448     (*delimiter-gestures* (apply #'make-delimiter-gestures
449     :existing-delimiter-args
450     (delimiter-gestures query)
451     accept-args)))
452     ;; If there was an error on a previous pass, set the insertion pointer to
453     ;; 0 so the user has a chance to edit the field without causing another
454     ;; error. Otherwise the insertion pointer should already be at the end of
455     ;; the input (because it was activated); perhaps we should set it anyway.
456     (when (accept-condition query)
457     (setf (stream-insertion-pointer estream) 0))
458     (reset-scan-pointer estream)
459     (setf (accept-condition query) nil)
460     ;; If a condition is thrown, then accept should return the old value and
461     ;; ptype.
462     (block accept-condition-handler
463     (setf (changedp query) nil)
464     (setf (values (value query) (ptype query))
465     (input-editing-rescan-loop
466     estream
467     #'(lambda (s)
468     (handler-bind
469     ((error
470     #'(lambda (c)
471     (format *trace-output*
472     "accepting-values accept condition: ~A~%"
473     c)
474     (if interactive
475     (progn
476     (beep)
477     (goatee::set-editing-stream-insertion-pointer
478     estream
479     (1- (stream-scan-pointer estream)))
480     (immediate-rescan estream)
481     (format *trace-output* "Ack!~%"))
482     (progn
483     (setf (accept-condition query) c)
484     (return-from accept-condition-handler
485     c))))))
486     (goatee::update-input-editing-stream s)
487     (if default-supplied-p
488     (accept ptype :stream s
489     :view view :prompt nil :default default)
490     (accept ptype :stream s :view view :prompt nil))))))
491     (setf (changedp query) t))))
492    
493 moore 1.12
494 moore 1.5
495    
496     ;;; The desired
497     (defmethod select-query (stream query (record av-text-record))
498     (declare (ignore stream))
499     (let ((estream (editing-stream record))
500     (ptype (ptype query))
501 tmoore 1.18 (view (view query)))
502 moore 1.5 (declare (ignore ptype view)) ;for now
503 tmoore 1.18 (with-accessors ((stream-input-buffer stream-input-buffer))
504 moore 1.5 estream
505 tmoore 1.18 (setf (cursor-visibility estream) t)
506     (setf (snapshot record) (copy-seq stream-input-buffer))
507     (av-do-accept query record t))))
508 moore 1.5
509    
510 tmoore 1.18 ;;; If the query has not been changed (i.e., ACCEPT didn't return) and there is
511     ;;; no error, act as if the user activated the query.
512 moore 1.5 (defmethod deselect-query (stream query (record av-text-record))
513     (let ((estream (editing-stream record)))
514 tmoore 1.18 (setf (cursor-visibility estream) nil)
515     (when (not (or (changedp query) (accept-condition query)))
516     (finalize-query-record query record))))
517    
518 moore 1.5
519     (defgeneric finalize-query-record (query record)
520     (:documentation "Do any cleanup on a query before the accepting-values body
521     is run for the last time"))
522    
523     (defmethod finalize-query-record (query record)
524     nil)
525    
526     ;;; If the user edits a text field, selects another text field and
527     ;;; then exits from accepting-values without activating the first
528     ;;; field, the values returned would be some previous value or default
529     ;;; for the field, not what's on the screen. That would be completely
530     ;;; bogus. So, if a field has been edited but not activated, activate
531     ;;; it now. Unfortunately that's a bit hairy.
532    
533     (defmethod finalize-query-record (query (record av-text-record))
534     (let ((estream (editing-stream record)))
535 tmoore 1.18 (when (and (snapshot record)
536 moore 1.5 (not (equal (snapshot record)
537     (stream-input-buffer estream))))
538     (let* ((activation-gestures (apply #'make-activation-gestures
539     :existing-activation-gestures
540     (activation-gestures query)
541     (accept-arguments query)))
542     (gesture (car activation-gestures)))
543     (when gesture
544     (let ((c (character-gesture-name gesture)))
545 tmoore 1.18 (activate-stream estream c)
546 moore 1.5 (reset-scan-pointer estream)
547 tmoore 1.18 (av-do-accept query record nil)))))))
548 moore 1.5
549     (defun finalize-query-records (av-stream)
550     (loop for query in (queries av-stream)
551     do (finalize-query-record query (record query))))
552    
553    
554     (define-presentation-to-command-translator com-select-field
555     (selectable-query com-select-query accepting-values
556     :gesture :select
557     :documentation "Select field for input"
558     :pointer-documentation "Select field for input"
559     :echo nil
560     :tester ((object)
561     (let ((selected (selected-query *accepting-values-stream*)))
562     (or (null selected)
563     (not (eq (query-identifier selected) object))))))
564     (object)
565     `(,object))
566    
567     (define-presentation-to-command-translator com-exit-button
568     (exit-button com-query-exit accepting-values
569     :gesture :select
570     :documentation "Exit dialog"
571     :pointer-documentation "Exit dialog"
572     :echo nil)
573     ()
574     ())
575    
576     (define-presentation-to-command-translator com-abort-button
577     (abort-button com-query-abort accepting-values
578     :gesture :select
579     :documentation "Abort dialog"
580     :pointer-documentation "Abort dialog"
581     :echo nil)
582     ()
583     ())
584 adejneka 1.1
585 moore 1.5 (defun accepting-values-default-command ()
586     (loop
587     (read-gesture :stream *accepting-values-stream*)))

  ViewVC Help
Powered by ViewVC 1.1.5