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

Contents of /mcclim/dialog.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.15 - (hide annotations)
Sun Jan 2 05:24:49 2005 UTC (9 years, 3 months ago) by ahefner
Branch: MAIN
Changes since 1.14: +48 -45 lines
Add new :inset border shape. Use this to surround text fields created by accepting-values.
Reduce offset of :drop-shadow border by one pixel, to three pixels.

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

  ViewVC Help
Powered by ViewVC 1.1.5