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

Contents of /mcclim/dialog.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.6 - (hide annotations)
Fri Jul 4 06:38:06 2003 UTC (10 years, 9 months ago) by moore
Branch: MAIN
Changes since 1.5: +2 -1 lines

Some cleanup of deleted Goatee area and screen-line methods.

Provide foreground-ink and background-ink slots for Goatee areas.

When an updating-output record is deleted, also delete it from its parent cache.
This prevents it from "coming back from the dead" later.
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 moore 1.6 :cursor-visibility nil
317     :background-ink +grey90+))))))
318 moore 1.5 (when editing-stream
319     (setf (editing-stream record) editing-stream))
320     record))
321    
322     (defun av-do-accept (query record)
323     (let ((estream (editing-stream record))
324     (ptype (ptype query))
325     (view (view query)))
326     (setf (values (value query) (ptype query)) ; Hmm, should ptype be set here?
327     (input-editing-rescan-loop
328     estream
329     #'(lambda (s)
330     (accept ptype :stream s :view view :prompt nil))))))
331    
332    
333     ;;; The desired
334     (defmethod select-query (stream query (record av-text-record))
335     (declare (ignore stream))
336     (let ((estream (editing-stream record))
337     (ptype (ptype query))
338     (view (view query))
339     (accept-args (accept-arguments query)))
340     (declare (ignore ptype view)) ;for now
341     (let* ((*activation-gestures* (apply #'make-activation-gestures
342     :existing-activation-gestures
343     (activation-gestures query)
344     accept-args))
345    
346     (*delimiter-gestures* (apply #'make-delimiter-gestures
347     :existing-delimiter-args
348     (delimiter-gestures query)
349     accept-args)))
350     (with-accessors ((stream-activated stream-activated)
351     (stream-input-buffer stream-input-buffer))
352     estream
353     ;; "deactivate" editing stream if user has previously activated it.
354     (when stream-activated
355     (setf stream-activated nil)
356     (when (activation-gesture-p (aref stream-input-buffer
357     (1- (fill-pointer
358     stream-input-buffer))))
359     (replace-input estream ""
360     :buffer-start (1- (fill-pointer
361     stream-input-buffer))
362     :rescan t)))
363     (setf (cursor-visibility estream) t)
364     (setf (snapshot record) (copy-seq stream-input-buffer))
365     (handler-case
366     (av-do-accept query record)
367     (condition (c)
368     (setf (condition query) c)))))))
369    
370    
371     (defmethod deselect-query (stream query (record av-text-record))
372     (let ((estream (editing-stream record)))
373     (setf (cursor-visibility estream) nil)))
374    
375     (defgeneric finalize-query-record (query record)
376     (:documentation "Do any cleanup on a query before the accepting-values body
377     is run for the last time"))
378    
379     (defmethod finalize-query-record (query record)
380     nil)
381    
382     ;;; If the user edits a text field, selects another text field and
383     ;;; then exits from accepting-values without activating the first
384     ;;; field, the values returned would be some previous value or default
385     ;;; for the field, not what's on the screen. That would be completely
386     ;;; bogus. So, if a field has been edited but not activated, activate
387     ;;; it now. Unfortunately that's a bit hairy.
388    
389     (defmethod finalize-query-record (query (record av-text-record))
390     (let ((estream (editing-stream record)))
391     (when (and (not (stream-activated estream))
392     (snapshot record)
393     (not (equal (snapshot record)
394     (stream-input-buffer estream))))
395     (let* ((activation-gestures (apply #'make-activation-gestures
396     :existing-activation-gestures
397     (activation-gestures query)
398     (accept-arguments query)))
399     (gesture (car activation-gestures)))
400     (when gesture
401     (let ((c (character-gesture-name gesture)))
402     (replace-input estream (string c)
403     :buffer-start (fill-pointer (stream-input-buffer
404     estream))
405     :rescan nil)
406     (setf (stream-activated estream) t)
407     (reset-scan-pointer estream)
408     (av-do-accept query record)))))))
409    
410     (defun finalize-query-records (av-stream)
411     (loop for query in (queries av-stream)
412     do (finalize-query-record query (record query))))
413    
414    
415     (define-presentation-to-command-translator com-select-field
416     (selectable-query com-select-query accepting-values
417     :gesture :select
418     :documentation "Select field for input"
419     :pointer-documentation "Select field for input"
420     :echo nil
421     :tester ((object)
422     (let ((selected (selected-query *accepting-values-stream*)))
423     (or (null selected)
424     (not (eq (query-identifier selected) object))))))
425     (object)
426     `(,object))
427    
428     (define-presentation-to-command-translator com-exit-button
429     (exit-button com-query-exit accepting-values
430     :gesture :select
431     :documentation "Exit dialog"
432     :pointer-documentation "Exit dialog"
433     :echo nil)
434     ()
435     ())
436    
437     (define-presentation-to-command-translator com-abort-button
438     (abort-button com-query-abort accepting-values
439     :gesture :select
440     :documentation "Abort dialog"
441     :pointer-documentation "Abort dialog"
442     :echo nil)
443     ()
444     ())
445 adejneka 1.1
446 moore 1.5 (defun accepting-values-default-command ()
447     (loop
448     (read-gesture :stream *accepting-values-stream*)))

  ViewVC Help
Powered by ViewVC 1.1.5