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

Contents of /mcclim/dialog.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.30 - (hide annotations)
Sat Dec 6 14:56:41 2008 UTC (5 years, 4 months ago) by ahefner
Branch: MAIN
Changes since 1.29: +39 -12 lines
Add new keyword to accepting-values, select-first-query, to automatically
select the first field in the dialog (we could do this using an existing
keyword, but figuring out the right query ID and getting it where it
needed to be looked like too much work). This highlights what I think
is an existing bug - the exit buttons often don't work when a field in
the dialog is accepting.

Minor aesthetic tweaks to accepting-values dialog (change border styles,
dress up exit buttons, rearrange some line breaks).
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 thenriksen 1.26 (define-command-table accept-values) ; :inherit-from nil???
121 moore 1.5
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 rstrandh 1.20 (defmacro with-stream-in-own-window ((&optional (stream '*query-io*)
140     &rest further-streams)
141 mretzlaff 1.22 (&optional label)
142 rstrandh 1.20 &rest body)
143 mretzlaff 1.22 `(let* ((,stream (open-window-stream :label ,label
144     :input-buffer (climi::frame-event-queue *application-frame*)))
145 rstrandh 1.20 ,@(mapcar (lambda (a-stream)
146     (list a-stream stream))
147     further-streams))
148     (unwind-protect
149     (progn
150     ,@body)
151     (close ,stream))))
152    
153 adejneka 1.1 (defmacro accepting-values
154     ((&optional (stream t)
155     &rest args
156     &key own-window exit-boxes initially-select-query-identifier
157     modify-initial-query resynchronize-every-pass resize-frame
158 ahefner 1.30 align-prompts label scroll-bars select-first-query
159 adejneka 1.1 x-position y-position width height command-table frame-class)
160     &body body)
161 rstrandh 1.20 (declare (ignorable exit-boxes initially-select-query-identifier
162 adejneka 1.1 modify-initial-query resynchronize-every-pass resize-frame
163 ahefner 1.30 align-prompts scroll-bars select-first-query
164 adejneka 1.1 x-position y-position width height command-table frame-class))
165 moore 1.12 (setq stream (stream-designator-symbol stream '*standard-input*))
166 adejneka 1.1 (with-gensyms (accepting-values-continuation)
167 thenriksen 1.25 (let* ((return-form
168     `(flet ((,accepting-values-continuation (,stream)
169     ,@body))
170     (invoke-accepting-values ,stream
171     #',accepting-values-continuation
172     ,@args)))
173     (true-form `(with-stream-in-own-window (,stream *standard-input* *standard-output*)
174     (,label)
175     ,return-form)))
176     ;; To avoid unreachable-code warnings, if `own-window' is a
177     ;; boolean constant, don't generate the `if' form.
178     (cond ((eq own-window t) true-form)
179     ((eq own-window nil) return-form)
180     (t `(if ,own-window
181     ,true-form
182     ,return-form))))))
183 moore 1.3
184     (defun invoke-accepting-values
185     (stream body
186 moore 1.13 &key own-window exit-boxes
187     (initially-select-query-identifier nil initially-select-p)
188 ahefner 1.30 select-first-query
189 moore 1.3 modify-initial-query resynchronize-every-pass resize-frame
190     align-prompts label scroll-bars
191 moore 1.5 x-position y-position width height
192 thenriksen 1.26 (command-table 'accept-values)
193 moore 1.3 (frame-class 'accept-values))
194 moore 1.13 (declare (ignore own-window exit-boxes modify-initial-query
195 moore 1.14 resize-frame label scroll-bars x-position y-position
196 rstrandh 1.20 width height frame-class))
197     (when (and align-prompts ;; t means the same as :right
198     (not (eq align-prompts :left)))
199     (setf align-prompts :right))
200 ahefner 1.15 (multiple-value-bind (cx cy) (stream-cursor-position stream)
201     (let* ((*accepting-values-stream*
202     (make-instance 'accepting-values-stream
203     :stream stream
204     :align-prompts align-prompts))
205     (arecord (updating-output (stream
206     :record-type 'accepting-values-record)
207     (if align-prompts
208     (formatting-table (stream)
209     (funcall body *accepting-values-stream*))
210     (funcall body *accepting-values-stream*))
211     (display-exit-boxes *application-frame*
212     stream
213     (stream-default-view
214     *accepting-values-stream*))))
215     (first-time t)
216     (current-command (if initially-select-p
217     `(com-select-query
218     ,initially-select-query-identifier)
219     *default-command*)))
220     (letf (((frame-command-table *application-frame*)
221     (find-command-table command-table)))
222     (unwind-protect
223     (handler-case
224     (loop
225     (if first-time
226     (setq first-time nil)
227     (when resynchronize-every-pass
228     (redisplay arecord stream)))
229     (with-input-context
230 thenriksen 1.26 ('(command :command-table accept-values))
231 ahefner 1.15 (object)
232     (progn
233 ahefner 1.30 (when (and select-first-query
234     (not initially-select-p))
235     (setf current-command
236     `(com-select-query
237     ,(query-identifier
238     (first
239     (queries *accepting-values-stream*))))
240     select-first-query nil))
241 ahefner 1.15 (apply (command-name current-command)
242     (command-arguments current-command))
243     ;; If current command returns without throwing a
244     ;; command, go back to the default command
245     (setq current-command *default-command*))
246     (t (setq current-command object)))
247     (redisplay arecord stream))
248     (av-exit ()
249     (finalize-query-records *accepting-values-stream*)
250 tmoore 1.18 (setf (last-pass *accepting-values-stream*) t)
251 ahefner 1.15 (redisplay arecord stream)))
252 thenriksen 1.29 (dolist (query (queries *accepting-values-stream*))
253     (finalize (editing-stream (record query)) nil))
254 ahefner 1.15 (erase-output-record arecord stream)
255     (setf (stream-cursor-position stream)
256     (values cx cy)))))))
257 moore 1.5
258     (defgeneric display-exit-boxes (frame stream view))
259    
260     (defmethod display-exit-boxes (frame stream (view textual-dialog-view))
261     (declare (ignore frame))
262     (updating-output (stream :unique-id 'buttons :cache-value t)
263     (fresh-line stream)
264 ahefner 1.30 (formatting-table (stream)
265     (formatting-row (stream)
266     (formatting-cell (stream)
267     (with-output-as-presentation (stream nil 'exit-button)
268     (surrounding-output-with-border
269     (stream :shape :rounded :radius 6
270     :background +gray80+ :highlight-background +gray90+)
271     (format stream "OK"))))
272     (formatting-cell (stream)
273     (with-output-as-presentation
274     (stream nil 'abort-button) (with-output-as-presentation
275     (stream nil 'exit-button)
276     (surrounding-output-with-border
277     (stream :shape :rounded :radius 6
278     :background +gray80+ :highlight-background +gray90+)
279     (format stream "Cancel")))))))
280 moore 1.5 (terpri stream)))
281    
282     (defmethod stream-accept ((stream accepting-values-stream) type
283     &rest rest-args
284     &key
285     (view (stream-default-view stream))
286     (default nil default-supplied-p)
287     default-type
288     provide-default
289     insert-default
290     replace-input
291     history
292     active-p
293     prompt
294     prompt-mode
295     display-default
296     (query-identifier prompt)
297     activation-gestures
298     additional-activation-gestures
299     delimiter-gestures
300     additional-delimiter-gestures)
301 rstrandh 1.28 (declare (ignore default-type provide-default insert-default replace-input
302     history active-p prompt-mode display-default
303     activation-gestures additional-activation-gestures
304 moore 1.5 delimiter-gestures additional-delimiter-gestures))
305     (let ((query (find query-identifier (queries stream)
306 moore 1.14 :key #'query-identifier :test #'equal))
307     (align (align-prompts stream)))
308 moore 1.5 (unless query
309 tmoore 1.19 ;; If there's no default but empty input could return a sensible value,
310     ;; use that as a default.
311     (unless default-supplied-p
312     (setq default
313     (ignore-errors (accept-from-string type
314     ""
315     :view +textual-view+ ))))
316 moore 1.5 (setq query (make-instance 'query
317     :query-identifier query-identifier
318     :ptype type
319     :view view
320     :default default
321 moore 1.12 :default-supplied-p default-supplied-p
322 moore 1.5 :value default))
323 thenriksen 1.26 (setf (queries stream) (nconc (queries stream) (list query)))
324     (when default
325     (setf (changedp query) t)))
326 moore 1.5 (setf (accept-arguments query) rest-args)
327     ;; If the program changes the default, that becomes the value.
328     (unless (equal default (default query))
329     (setf (default query) default)
330     (setf (value query) default))
331 moore 1.14 (flet ((do-prompt ()
332     (apply #'prompt-for-accept stream type view rest-args))
333     (do-accept-present-default ()
334     (funcall-presentation-generic-function
335     accept-present-default
336     type (encapsulating-stream-stream stream) view
337     (value query)
338     default-supplied-p nil query-identifier)))
339     (let ((query-record nil))
340     (if align
341     (formatting-row (stream)
342     (formatting-cell (stream :align-x align)
343     (do-prompt))
344     (formatting-cell (stream)
345     (setq query-record (do-accept-present-default))))
346     (progn
347     (do-prompt)
348     (setq query-record (do-accept-present-default))))
349     (setf (record query) query-record)
350 tmoore 1.18 (when (and (last-pass stream) (accept-condition query))
351 moore 1.14 (signal (accept-condition query)))
352     (multiple-value-prog1
353     (values (value query) (ptype query) (changedp query))
354     (setf (default query) default)
355     (setf (ptype query) type)
356     (setf (changedp query) nil))))))
357    
358 moore 1.5
359     (defmethod prompt-for-accept ((stream accepting-values-stream)
360     type view
361     &rest args)
362     (declare (ignore view))
363     (apply #'prompt-for-accept-1 stream type :display-default nil args))
364    
365 thenriksen 1.26 (define-command (com-query-exit :command-table accept-values
366 moore 1.11 :name nil
367     :provide-output-destination-keyword nil)
368 moore 1.5 ()
369     (signal 'av-exit))
370    
371 thenriksen 1.26 (define-command (com-query-abort :command-table accept-values
372 moore 1.11 :name nil
373     :provide-output-destination-keyword nil)
374 moore 1.5 ()
375     (and (find-restart 'abort)
376     (invoke-restart 'abort)))
377    
378 thenriksen 1.26 (define-command (com-change-query :command-table accept-values
379 moore 1.11 :name nil
380     :provide-output-destination-keyword nil)
381 moore 1.5 ((query-identifier t)
382     (value t))
383     (when *accepting-values-stream*
384     (let ((query (find query-identifier (queries *accepting-values-stream*)
385     :key #'query-identifier :test #'equal)))
386     (when query
387     (setf (value query) value)
388     (setf (changedp query) t)))))
389    
390     (defgeneric select-query (stream query record)
391     (:documentation "Does whatever is needed for input (e.g., calls accept) when
392 tmoore 1.17 a query is selected for input. It is responsible for updating the
393     query object when a new value is entered in the query field." ))
394 moore 1.5
395     (defgeneric deselect-query (stream query record)
396     (:documentation "Deselect a query field: turn the cursor off, turn off
397     highlighting, etc." ))
398 adejneka 1.1
399 thenriksen 1.26 (define-command (com-select-query :command-table accept-values
400 moore 1.11 :name nil
401     :provide-output-destination-keyword nil)
402 moore 1.5 ((query-identifier t))
403     (when *accepting-values-stream*
404     (with-accessors ((selected-query selected-query))
405     *accepting-values-stream*
406     (let* ((query-list (member query-identifier
407     (queries *accepting-values-stream*)
408     :key #'query-identifier :test #'equal))
409     (query (car query-list)))
410     (when selected-query
411 tmoore 1.18 (unless (equal query-identifier (query-identifier selected-query))
412 moore 1.5 (deselect-query *accepting-values-stream*
413     selected-query
414     (record selected-query))))
415     (when query
416     (setf selected-query query)
417     (select-query *accepting-values-stream* query (record query))
418 thenriksen 1.26 (let ((command-ptype '(command :command-table accept-values)))
419 tmoore 1.16 (if (cdr query-list)
420     (throw-object-ptype `(com-select-query ,(query-identifier
421     (cadr query-list)))
422     command-ptype)
423     (throw-object-ptype '(com-deselect-query) command-ptype))))))))
424 moore 1.5
425 thenriksen 1.26 (define-command (com-deselect-query :command-table accept-values
426 moore 1.11 :name nil
427     :provide-output-destination-keyword nil)
428 moore 1.5 ()
429     (when *accepting-values-stream*
430     (with-accessors ((selected-query selected-query))
431     *accepting-values-stream*
432     (when selected-query
433     (deselect-query *accepting-values-stream*
434     selected-query
435     (record selected-query))
436     (setf selected-query nil)))))
437    
438     (defclass av-text-record (standard-updating-output-record)
439     ((editing-stream :accessor editing-stream)
440     (snapshot :accessor snapshot :initarg :snapshot :initform nil
441     :documentation "A copy of the stream buffer before accept
442     is called. Used to determine if any editing has been done by user")))
443    
444 moore 1.13 (defparameter *no-default-cache-value* (cons nil nil))
445 tmoore 1.16
446     ;;; Hack until more views / dialog gadgets are defined.
447    
448     (define-default-presentation-method accept-present-default
449     (type stream (view text-field-view) default default-supplied-p
450     present-p query-identifier)
451     (if (width view)
452     (multiple-value-bind (cx cy)
453     (stream-cursor-position stream)
454     (declare (ignore cy))
455     (letf (((stream-text-margin stream) (+ cx (width view))))
456     (funcall-presentation-generic-function accept-present-default
457     type
458     stream
459     +textual-dialog-view+
460     default default-supplied-p
461     present-p
462     query-identifier)))))
463 moore 1.13
464 moore 1.5 (define-default-presentation-method accept-present-default
465     (type stream (view textual-dialog-view) default default-supplied-p
466     present-p query-identifier)
467 moore 1.12 (declare (ignore present-p))
468 moore 1.5 (let* ((editing-stream nil)
469     (record (updating-output (stream :unique-id query-identifier
470 thenriksen 1.23 :cache-value (if default-supplied-p
471     default
472     *no-default-cache-value*)
473     :record-type 'av-text-record)
474     (with-output-as-presentation
475     (stream query-identifier 'selectable-query
476     :single-box t)
477     (surrounding-output-with-border
478 ahefner 1.30 (stream :shape :rounded
479     :radius 3 :background +white+
480     :foreground +gray40+
481     :move-cursor t)
482     ;;; FIXME: In this instance we really want borders that
483     ;;; react to the growth of their children. This should
484     ;;; be straightforward unless there is some involvement
485     ;;; of incremental redisplay.
486     ;;; KLUDGE: Arbitrary min-width.
487 thenriksen 1.23 (setq editing-stream
488 thenriksen 1.24 (make-instance (if *use-goatee*
489     'goatee-input-editing-stream
490     'standard-input-editing-stream)
491 thenriksen 1.23 :stream stream
492     :cursor-visibility nil
493     :single-line t
494 ahefner 1.30 :min-width (- (bounding-rectangle-max-x stream)
495     (stream-cursor-position stream)
496     100)))))
497 thenriksen 1.23 (when default-supplied-p
498     (input-editing-rescan-loop ;XXX probably not needed
499     editing-stream
500     (lambda (s)
501     (presentation-replace-input s default type view
502     :rescan t)))))))
503 moore 1.5 (when editing-stream
504     (setf (editing-stream record) editing-stream))
505     record))
506    
507 tmoore 1.18 (defun av-do-accept (query record interactive)
508     (let* ((estream (editing-stream record))
509     (ptype (ptype query))
510     (view (view query))
511     (default (default query))
512     (default-supplied-p (default-supplied-p query))
513     (accept-args (accept-arguments query))
514     (*activation-gestures* (apply #'make-activation-gestures
515     :existing-activation-gestures
516     (activation-gestures query)
517     accept-args))
518     (*delimiter-gestures* (apply #'make-delimiter-gestures
519     :existing-delimiter-args
520     (delimiter-gestures query)
521     accept-args)))
522     ;; If there was an error on a previous pass, set the insertion pointer to
523     ;; 0 so the user has a chance to edit the field without causing another
524     ;; error. Otherwise the insertion pointer should already be at the end of
525     ;; the input (because it was activated); perhaps we should set it anyway.
526     (when (accept-condition query)
527     (setf (stream-insertion-pointer estream) 0))
528     (reset-scan-pointer estream)
529     (setf (accept-condition query) nil)
530     ;; If a condition is thrown, then accept should return the old value and
531     ;; ptype.
532     (block accept-condition-handler
533     (setf (changedp query) nil)
534     (setf (values (value query) (ptype query))
535     (input-editing-rescan-loop
536     estream
537     #'(lambda (s)
538     (handler-bind
539     ((error
540     #'(lambda (c)
541     (format *trace-output*
542 thenriksen 1.23 "accepting-values accept condition: ~A~%"
543     c)
544 tmoore 1.18 (if interactive
545 thenriksen 1.23 (progn
546     (beep)
547     (setf (stream-insertion-pointer estream)
548     (max 0 (1- (stream-scan-pointer estream))))
549     (immediate-rescan estream)
550     (format *trace-output* "Ack!~%"))
551     (progn
552     (setf (accept-condition query) c)
553     (return-from accept-condition-handler
554     c))))))
555 tmoore 1.18 (if default-supplied-p
556     (accept ptype :stream s
557     :view view :prompt nil :default default)
558     (accept ptype :stream s :view view :prompt nil))))))
559     (setf (changedp query) t))))
560    
561 moore 1.12
562 moore 1.5
563    
564     ;;; The desired
565     (defmethod select-query (stream query (record av-text-record))
566     (declare (ignore stream))
567     (let ((estream (editing-stream record))
568     (ptype (ptype query))
569 tmoore 1.18 (view (view query)))
570 moore 1.5 (declare (ignore ptype view)) ;for now
571 tmoore 1.18 (with-accessors ((stream-input-buffer stream-input-buffer))
572 moore 1.5 estream
573 tmoore 1.18 (setf (cursor-visibility estream) t)
574     (setf (snapshot record) (copy-seq stream-input-buffer))
575     (av-do-accept query record t))))
576 moore 1.5
577    
578 tmoore 1.18 ;;; If the query has not been changed (i.e., ACCEPT didn't return) and there is
579     ;;; no error, act as if the user activated the query.
580 moore 1.5 (defmethod deselect-query (stream query (record av-text-record))
581     (let ((estream (editing-stream record)))
582 tmoore 1.18 (setf (cursor-visibility estream) nil)
583     (when (not (or (changedp query) (accept-condition query)))
584     (finalize-query-record query record))))
585    
586 moore 1.5
587     (defgeneric finalize-query-record (query record)
588     (:documentation "Do any cleanup on a query before the accepting-values body
589     is run for the last time"))
590    
591     (defmethod finalize-query-record (query record)
592     nil)
593    
594     ;;; If the user edits a text field, selects another text field and
595     ;;; then exits from accepting-values without activating the first
596     ;;; field, the values returned would be some previous value or default
597     ;;; for the field, not what's on the screen. That would be completely
598     ;;; bogus. So, if a field has been edited but not activated, activate
599     ;;; it now. Unfortunately that's a bit hairy.
600    
601     (defmethod finalize-query-record (query (record av-text-record))
602     (let ((estream (editing-stream record)))
603 tmoore 1.18 (when (and (snapshot record)
604 moore 1.5 (not (equal (snapshot record)
605     (stream-input-buffer estream))))
606     (let* ((activation-gestures (apply #'make-activation-gestures
607     :existing-activation-gestures
608     (activation-gestures query)
609     (accept-arguments query)))
610     (gesture (car activation-gestures)))
611     (when gesture
612     (let ((c (character-gesture-name gesture)))
613 tmoore 1.18 (activate-stream estream c)
614 moore 1.5 (reset-scan-pointer estream)
615 tmoore 1.18 (av-do-accept query record nil)))))))
616 moore 1.5
617     (defun finalize-query-records (av-stream)
618     (loop for query in (queries av-stream)
619     do (finalize-query-record query (record query))))
620    
621    
622     (define-presentation-to-command-translator com-select-field
623 thenriksen 1.26 (selectable-query com-select-query accept-values
624 moore 1.5 :gesture :select
625     :documentation "Select field for input"
626     :pointer-documentation "Select field for input"
627     :echo nil
628     :tester ((object)
629     (let ((selected (selected-query *accepting-values-stream*)))
630     (or (null selected)
631     (not (eq (query-identifier selected) object))))))
632     (object)
633     `(,object))
634    
635     (define-presentation-to-command-translator com-exit-button
636 thenriksen 1.26 (exit-button com-query-exit accept-values
637 moore 1.5 :gesture :select
638     :documentation "Exit dialog"
639     :pointer-documentation "Exit dialog"
640     :echo nil)
641     ()
642     ())
643    
644     (define-presentation-to-command-translator com-abort-button
645 thenriksen 1.26 (abort-button com-query-abort accept-values
646 moore 1.5 :gesture :select
647     :documentation "Abort dialog"
648     :pointer-documentation "Abort dialog"
649     :echo nil)
650     ()
651     ())
652 adejneka 1.1
653 moore 1.5 (defun accepting-values-default-command ()
654     (loop
655     (read-gesture :stream *accepting-values-stream*)))
656 ahefner 1.27
657    
658     ;;;; notify-user
659    
660     ;;; See http://openmap.bbn.com/hypermail/clim/0028.html for example usage.
661    
662     ;;; TODO:
663     ;;; - associated-window argument?
664     ;;; - What is the correct return value from notify-user? We currently return
665     ;;; the name of the action given in the :exit-boxes argument.
666     ;;; - Invoke abort restart? Not necessary as it is with accepting-values,
667     ;;; but probably what "Classic CLIM" does.
668     ;;; - What are the default exit boxes? Just "Okay"? Okay and cancel?
669     ;;; - Reimplement using accepting-values, if accepting-values is ever
670     ;;; improved to produce comparable dialogs.
671     ;;; - Should the user really be able to close the window from the WM?
672    
673     (defmethod notify-user (frame message &rest args)
674     (apply #'frame-manager-notify-user
675     (if frame (frame-manager frame) (find-frame-manager))
676     message
677     :frame frame
678     args))
679    
680     (define-application-frame generic-notify-user-frame ()
681     ((message-string :initarg :message-string)
682     (exit-boxes :initarg :exit-boxes)
683     (title :initarg :title)
684     (style :initarg :style)
685     (text-style :initarg :text-style)
686     (return-value :initarg nil :initform :abort))
687     (:pane (generate-notify-user-dialog *application-frame*)))
688    
689     (defun generate-notify-user-dialog (frame)
690     (with-slots (message-string exit-boxes text-style) frame
691     (vertically ()
692     (spacing (:thickness 6)
693     (make-pane 'label-pane :label (or message-string "I'm speechless.") :text-style text-style))
694     (spacing (:thickness 4)
695     (make-pane 'hbox-pane :contents (cons '+fill+ (generate-exit-box-buttons exit-boxes)))))))
696    
697     (defun generate-exit-box-buttons (specs)
698     (mapcar
699     (lambda (spec)
700     (destructuring-bind (action string &rest args) spec
701     (spacing (:thickness 2)
702     (apply #'make-pane
703     'push-button
704     :label string
705     :text-style (make-text-style :sans-serif :roman :small) ; XXX
706     :activate-callback
707     (lambda (gadget)
708     (declare (ignore gadget))
709     ;; This is fboundp business is weird, and only implied by a
710     ;; random message on the old CLIM list. Does the user function
711     ;; take arguments?
712     (when (or (typep action 'function) (fboundp action))
713     (funcall action))
714     (setf (slot-value *application-frame* 'return-value) action)
715     ;; This doesn't work:
716     #+NIL
717     (when (eql action :abort)
718     (and (find-restart 'abort)
719     (invoke-restart 'abort)))
720     (frame-exit *application-frame*))
721     args))))
722     specs))
723    
724    
725     (defmethod frame-manager-notify-user
726     (frame-manager message-string &key frame associated-window
727     (title "")
728     documentation
729     (exit-boxes '((:exit "OK")))
730     ; The 'name' arg is in the spec but absent from the Lispworks
731     ; manual, and I can't imagine what it would do differently
732     ; than 'title'.
733     name
734     style
735     (text-style (make-text-style :sans-serif :roman :small)))
736     (declare (ignore associated-window documentation))
737     ;; Keywords from notify-user:
738     ;; associated-window title documentation exit-boxes name style text-style
739     (let ((frame (make-application-frame 'generic-notify-user-frame
740     :frame-event-queue (and frame (frame-event-queue frame))
741     :pretty-name title
742     :message-string message-string
743     :frame-manager frame-manager
744     :exit-boxes exit-boxes
745     :title (or name title)
746     :style style
747     :text-style text-style)))
748     (run-frame-top-level frame)
749     (slot-value frame 'return-value)))

  ViewVC Help
Powered by ViewVC 1.1.5