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

Contents of /mcclim/dialog.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.11 - (hide annotations)
Wed Mar 24 09:30:29 2004 UTC (10 years ago) by moore
Branch: MAIN
Changes since 1.10: +15 -5 lines
2004-03-24  Timothy Moore  <moore@bricoworks.com>

	* INSTALL.OPENMCL: updated instructions.

	* builtin-commands.lisp (default-translator): Return the
	presentation type of the presentation as the second value.
	(document-form-translator): New function
	(%frob-constant-form, %frob-form): Use document-form-translator. Add
	translators from standard-object to expression and form.
	(expression-as-form): Add a menu entry for this translator.
	(ccl::%read-list-expression, (accept expression t textual-view),
	read, read-preserving-whitespace): Move the Lisp form reader
	stuff from the ptype 'form to the ptype 'expression. Disallow any
	activation or delimiter gestures while reading an expression.

	* commands.lisp (command-name-from-symbol): Don't strip leading
	subsequences of "COM-" from the command name.
	(keyword-arg-name-from-symbol): New function.
	(command-parsers): Add argument-unparser slot
	(make-keyword): New function
	(make-key-accessors): Use it. Accept keynames that begin with a
	#\: and have dashes replaced by spaces.
	(make-unprocessor-fun) New function to create an unprocessor
	function for each command.
	(%define-command): New macro preserving  old behavior. Use new
	unprocessor stuff.
	(output-destination, invoke-with-standard-output): New class and
	generic function for outputing the results of commands to an
	output stream.
	(define-command): Implement :provide-output-destination-keyword
	(command-line-unparser): Call new stuff instead.

	* dialog.lisp: Add (redundant):provide-output-destination-keyword
	keyword argument to some commands.

	* incremental-redisplay.lisp: Work in progress. Turn things
	inside-out.

	* input-editing.lisp (complete-input): Don't insert input when mode is
	:complete and we've failed.

	* presentation-defs.lisp (accept-1): Use multiple-value-list when
	looking at results of accept method.
	((present t completion t t)): Use the arguments to the type to drive
	the present method here.
	((accept sequence t textual-view)): Don't peek-char initially! It
	breaks accepting the first element via mouse click.
	(accept sequence-enumerated t textual-view): new method.

	* recording.lisp : Cosmetic fixups.

	* regions.lisp (ellipse-normal-radii*): Add Gilbert's English
	translation of the comment and clean up the function.

	* system.lisp: Add Goatee/presentation-history.

	* transforms.lisp (+identity-transformation+): Move earlier in the
	file to avoid a warning.

	* utils.lisp (delete-1, parse-lambda-list): new functions.

	* Apps/Listener/dev-commands.lisp : Add
	:provide-output-destination-keyword argument to many commands.
	((presentation-type generic-function)): Rewrite. Make it inherit from
	t, add accept method. The type of the object is generic-function, not
	the name or something.
	((presentation-type standard-generic-function), (presentation-type
	method), (presentation-type standard-method)): add.
	(Show Generic Function): All-singing all-dancing command for exploring
	generic functions and their methods.
	((presentation-type package)): New type with completing accept method.
	(Set Package): New command

	* Apps/Listener/listener.lisp (run-frame-top-level): Add bindings for
	all the Common Lisp reader and printer variables.

	* Apps/Scigraph/dwim/macros.lisp (define-command): Add
	:provide-output-destination-keyword support for McCLIM.

	* Goatee/goatee-command.lisp (lookup-gesture-command): Disable
	annoying debugging output.

	* Lisp-Dep/fix-openmcl.lisp (:clim-mop): In OpenMCL 0.14 use and
	export all symbols from :openmcl-mop.
	(compute-applicable-methods-using-classes): Hack for the listener.
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     (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 moore 1.7 (when (accept-condition query)
223     (signal (accept-condition query)))
224 moore 1.5 (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 moore 1.11 (define-command (com-query-exit :command-table accepting-values
237     :name nil
238     :provide-output-destination-keyword nil)
239 moore 1.5 ()
240     (signal 'av-exit))
241    
242 moore 1.11 (define-command (com-query-abort :command-table accepting-values
243     :name nil
244     :provide-output-destination-keyword nil)
245 moore 1.5 ()
246     (and (find-restart 'abort)
247     (invoke-restart 'abort)))
248    
249 moore 1.11 (define-command (com-change-query :command-table accepting-values
250     :name nil
251     :provide-output-destination-keyword nil)
252 moore 1.5 ((query-identifier t)
253     (value t))
254     (when *accepting-values-stream*
255     (let ((query (find query-identifier (queries *accepting-values-stream*)
256     :key #'query-identifier :test #'equal)))
257     (when query
258     (setf (value query) value)
259     (setf (changedp query) t)))))
260    
261     (defgeneric select-query (stream query record)
262     (:documentation "Does whatever is needed for input (e.g., calls accept) when
263     a query is selected for input." ))
264    
265     (defgeneric deselect-query (stream query record)
266     (:documentation "Deselect a query field: turn the cursor off, turn off
267     highlighting, etc." ))
268 adejneka 1.1
269 moore 1.11 (define-command (com-select-query :command-table accepting-values
270     :name nil
271     :provide-output-destination-keyword nil)
272 moore 1.5 ((query-identifier t))
273     (when *accepting-values-stream*
274     (with-accessors ((selected-query selected-query))
275     *accepting-values-stream*
276     (let* ((query-list (member query-identifier
277     (queries *accepting-values-stream*)
278     :key #'query-identifier :test #'equal))
279     (query (car query-list)))
280     (when selected-query
281     (unless (equal query-identifier
282     (query-identifier selected-query))
283     (deselect-query *accepting-values-stream*
284     selected-query
285     (record selected-query))))
286     (when query
287     (setf selected-query query)
288     (select-query *accepting-values-stream* query (record query))
289     (if (cdr query-list)
290     (throw-object-ptype (query-identifier (cadr query-list))
291     'selectable-query)
292     (throw-object-ptype '(com-deselect-query)
293     '(command :command-table accepting-values))))))))
294    
295 moore 1.11 (define-command (com-deselect-query :command-table accepting-values
296     :name nil
297     :provide-output-destination-keyword nil)
298 moore 1.5 ()
299     (when *accepting-values-stream*
300     (with-accessors ((selected-query selected-query))
301     *accepting-values-stream*
302     (when selected-query
303     (deselect-query *accepting-values-stream*
304     selected-query
305     (record selected-query))
306     (setf selected-query nil)))))
307    
308     (defclass av-text-record (standard-updating-output-record)
309     ((editing-stream :accessor editing-stream)
310     (snapshot :accessor snapshot :initarg :snapshot :initform nil
311     :documentation "A copy of the stream buffer before accept
312     is called. Used to determine if any editing has been done by user")))
313    
314     (define-default-presentation-method accept-present-default
315     (type stream (view textual-dialog-view) default default-supplied-p
316     present-p query-identifier)
317     (let* ((editing-stream nil)
318     (record (updating-output (stream :unique-id query-identifier
319     :cache-value query-identifier
320     :record-type 'av-text-record)
321     (with-output-as-presentation
322     (stream query-identifier 'selectable-query)
323 moore 1.8 (surrounding-output-with-border
324     (stream :shape :drop-shadow :move-cursor t)
325     (setq editing-stream
326     (make-instance 'standard-input-editing-stream
327     :stream stream
328     :cursor-visibility nil
329 moore 1.9 :background-ink +grey90+))))
330     (when default-supplied-p
331     (input-editing-rescan-loop ;XXX probably not needed
332     editing-stream
333     (lambda (s)
334     (presentation-replace-input s default type view
335     :rescan t)
336     (goatee::update-input-editing-stream s)))))))
337 moore 1.5 (when editing-stream
338     (setf (editing-stream record) editing-stream))
339     record))
340    
341     (defun av-do-accept (query record)
342     (let ((estream (editing-stream record))
343     (ptype (ptype query))
344     (view (view query)))
345     (setf (values (value query) (ptype query)) ; Hmm, should ptype be set here?
346     (input-editing-rescan-loop
347     estream
348     #'(lambda (s)
349     (accept ptype :stream s :view view :prompt nil))))))
350    
351    
352     ;;; The desired
353     (defmethod select-query (stream query (record av-text-record))
354     (declare (ignore stream))
355     (let ((estream (editing-stream record))
356     (ptype (ptype query))
357     (view (view query))
358     (accept-args (accept-arguments query)))
359     (declare (ignore ptype view)) ;for now
360     (let* ((*activation-gestures* (apply #'make-activation-gestures
361     :existing-activation-gestures
362     (activation-gestures query)
363     accept-args))
364    
365     (*delimiter-gestures* (apply #'make-delimiter-gestures
366     :existing-delimiter-args
367     (delimiter-gestures query)
368     accept-args)))
369     (with-accessors ((stream-activated stream-activated)
370     (stream-input-buffer stream-input-buffer))
371     estream
372     ;; "deactivate" editing stream if user has previously activated it.
373     (when stream-activated
374     (setf stream-activated nil)
375     (when (activation-gesture-p (aref stream-input-buffer
376     (1- (fill-pointer
377     stream-input-buffer))))
378     (replace-input estream ""
379     :buffer-start (1- (fill-pointer
380     stream-input-buffer))
381     :rescan t)))
382     (setf (cursor-visibility estream) t)
383     (setf (snapshot record) (copy-seq stream-input-buffer))
384     (handler-case
385     (av-do-accept query record)
386     (condition (c)
387 moore 1.9 (format *trace-output* "accepting-values accept condition: ~A~%"
388     c)
389 moore 1.7 (setf (accept-condition query) c)))))))
390 moore 1.5
391    
392     (defmethod deselect-query (stream query (record av-text-record))
393     (let ((estream (editing-stream record)))
394     (setf (cursor-visibility estream) nil)))
395    
396     (defgeneric finalize-query-record (query record)
397     (:documentation "Do any cleanup on a query before the accepting-values body
398     is run for the last time"))
399    
400     (defmethod finalize-query-record (query record)
401     nil)
402    
403     ;;; If the user edits a text field, selects another text field and
404     ;;; then exits from accepting-values without activating the first
405     ;;; field, the values returned would be some previous value or default
406     ;;; for the field, not what's on the screen. That would be completely
407     ;;; bogus. So, if a field has been edited but not activated, activate
408     ;;; it now. Unfortunately that's a bit hairy.
409    
410     (defmethod finalize-query-record (query (record av-text-record))
411     (let ((estream (editing-stream record)))
412     (when (and (not (stream-activated estream))
413     (snapshot record)
414     (not (equal (snapshot record)
415     (stream-input-buffer estream))))
416     (let* ((activation-gestures (apply #'make-activation-gestures
417     :existing-activation-gestures
418     (activation-gestures query)
419     (accept-arguments query)))
420     (gesture (car activation-gestures)))
421     (when gesture
422     (let ((c (character-gesture-name gesture)))
423     (replace-input estream (string c)
424     :buffer-start (fill-pointer (stream-input-buffer
425     estream))
426     :rescan nil)
427     (setf (stream-activated estream) t)
428     (reset-scan-pointer estream)
429     (av-do-accept query record)))))))
430    
431     (defun finalize-query-records (av-stream)
432     (loop for query in (queries av-stream)
433     do (finalize-query-record query (record query))))
434    
435    
436     (define-presentation-to-command-translator com-select-field
437     (selectable-query com-select-query accepting-values
438     :gesture :select
439     :documentation "Select field for input"
440     :pointer-documentation "Select field for input"
441     :echo nil
442     :tester ((object)
443     (let ((selected (selected-query *accepting-values-stream*)))
444     (or (null selected)
445     (not (eq (query-identifier selected) object))))))
446     (object)
447     `(,object))
448    
449     (define-presentation-to-command-translator com-exit-button
450     (exit-button com-query-exit accepting-values
451     :gesture :select
452     :documentation "Exit dialog"
453     :pointer-documentation "Exit dialog"
454     :echo nil)
455     ()
456     ())
457    
458     (define-presentation-to-command-translator com-abort-button
459     (abort-button com-query-abort accepting-values
460     :gesture :select
461     :documentation "Abort dialog"
462     :pointer-documentation "Abort dialog"
463     :echo nil)
464     ()
465     ())
466 adejneka 1.1
467 moore 1.5 (defun accepting-values-default-command ()
468     (loop
469     (read-gesture :stream *accepting-values-stream*)))

  ViewVC Help
Powered by ViewVC 1.1.5