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

Contents of /mcclim/dialog.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5