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

Contents of /mcclim/dialog.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.9 - (hide annotations)
Wed Jan 7 05:05:07 2004 UTC (10 years, 3 months ago) by moore
Branch: MAIN
Changes since 1.8: +10 -1 lines
Work in progress on the OpenGL backend, but nothing's working
yet. Refactored the KeySym and modifiers code in the CLX backend so
that it can be used by the OpenGL backend too.

Fixed a typo in presentation-replace-input; it was always creating
accept result extents.

Added support in accepting-values for placing the default in the text
entry field and fixed several problems that turned up as a result.

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

  ViewVC Help
Powered by ViewVC 1.1.5