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

Contents of /mcclim/dialog.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.14 - (hide annotations)
Sun Oct 24 15:47:02 2004 UTC (9 years, 6 months ago) by moore
Branch: MAIN
Changes since 1.13: +53 -27 lines
Implemented :ALIGN-PROMPTS in ACCEPTING-VALUES. This was harder than
it sounds, requiring several changes and cleanups:

Moved the call to PROMPT-FOR-ACCEPT from ACCEPT to STREAM-ACCEPT. The
spec vaguely hints that ACCEPT is responsible for drawing the prompt,
but that makes things like wrapping the calls to PROMPT-FOR-ACCEPT
and ACCEPT-PRESENT-DEFAULT inside a table formatting directive hard
to do. This shouldn't affect any user code.

Made Goatee input streams play nice with output recording. Added the
notion of a NEWLINE-CHARACTER to Goatee buffers; NIL is valid, so one
can construct Goatee areas that will only have one line. This
eliminates a lot of ugliness from ACCEPTING-VALUES dialogs.

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

  ViewVC Help
Powered by ViewVC 1.1.5