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

Diff of /mcclim/dialog.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.17 by tmoore, Tue Jan 18 10:58:08 2005 UTC revision 1.18 by tmoore, Tue Feb 22 14:00:10 2005 UTC
# Line 102  accept of this query"))) Line 102  accept of this query")))
102    ((queries :accessor queries :initform nil)    ((queries :accessor queries :initform nil)
103     (selected-query :accessor selected-query :initform nil)     (selected-query :accessor selected-query :initform nil)
104     (align-prompts :accessor align-prompts :initarg :align-prompts     (align-prompts :accessor align-prompts :initarg :align-prompts
105                    :initform nil)))                    :initform nil)
106       (last-pass :accessor last-pass :initform nil
107                  :documentation "Flag that indicates the last pass through the
108      body of ACCEPTING-VALUES, after the user has chosen to exit. This controls
109      when conditions will be signalled from calls to ACCEPT.")))
110    
111  (defmethod stream-default-view ((stream accepting-values-stream))  (defmethod stream-default-view ((stream accepting-values-stream))
112    +textual-dialog-view+)    +textual-dialog-view+)
# Line 206  accept of this query"))) Line 210  accept of this query")))
210                      (redisplay arecord stream))                      (redisplay arecord stream))
211                 (av-exit ()                 (av-exit ()
212                   (finalize-query-records *accepting-values-stream*)                   (finalize-query-records *accepting-values-stream*)
213                     (setf (last-pass *accepting-values-stream*) t)
214                   (redisplay arecord stream)))                   (redisplay arecord stream)))
215            (erase-output-record arecord stream)            (erase-output-record arecord stream)
216            (setf (stream-cursor-position stream)            (setf (stream-cursor-position stream)
# Line 283  accept of this query"))) Line 288  accept of this query")))
288                (do-prompt)                (do-prompt)
289                (setq query-record (do-accept-present-default))))                (setq query-record (do-accept-present-default))))
290          (setf (record query) query-record)          (setf (record query) query-record)
291          (when (accept-condition query)          (when (and (last-pass stream) (accept-condition query))
292            (signal (accept-condition query)))            (signal (accept-condition query)))
293          (multiple-value-prog1          (multiple-value-prog1
294              (values (value query) (ptype query) (changedp query))              (values (value query) (ptype query) (changedp query))
# Line 344  highlighting, etc." )) Line 349  highlighting, etc." ))
349                                   :key #'query-identifier :test #'equal))                                   :key #'query-identifier :test #'equal))
350               (query (car query-list)))               (query (car query-list)))
351          (when selected-query          (when selected-query
352            (unless (equal query-identifier            (unless (equal query-identifier (query-identifier selected-query))
                          (query-identifier selected-query))  
353              (deselect-query *accepting-values-stream*              (deselect-query *accepting-values-stream*
354                              selected-query                              selected-query
355                              (record selected-query))))                              (record selected-query))))
# Line 409  is called. Used to determine if any edit Line 413  is called. Used to determine if any edit
413                                                      *no-default-cache-value*)                                                      *no-default-cache-value*)
414                                     :record-type 'av-text-record)                                     :record-type 'av-text-record)
415                     (with-output-as-presentation                     (with-output-as-presentation
416                         (stream query-identifier 'selectable-query)                         (stream query-identifier 'selectable-query
417                                   :single-box t)
418                       (surrounding-output-with-border                       (surrounding-output-with-border
419                           (stream :shape :inset :move-cursor t)                           (stream :shape :inset :move-cursor t)
420                         (setq editing-stream                         (setq editing-stream
# Line 429  is called. Used to determine if any edit Line 434  is called. Used to determine if any edit
434        (setf (editing-stream record) editing-stream))        (setf (editing-stream record) editing-stream))
435      record))      record))
436    
437  (defun av-do-accept (query record)  (defun av-do-accept (query record interactive)
438    (let ((estream (editing-stream record))    (let* ((estream (editing-stream record))
439          (ptype (ptype query))           (ptype (ptype query))
440          (view (view query))           (view (view query))
441          (default (default query))           (default (default query))
442          (default-supplied-p (default-supplied-p query)))           (default-supplied-p (default-supplied-p query))
443      (setf (values (value query) (ptype query)) ; Hmm, should ptype be set here?           (accept-args (accept-arguments query))
444            (input-editing-rescan-loop           (*activation-gestures* (apply #'make-activation-gestures
445             estream                                         :existing-activation-gestures
446             (if default-supplied-p                                         (activation-gestures query)
447                 ;; Allow empty input to return a default value                                         accept-args))
448                 #'(lambda (s)           (*delimiter-gestures* (apply #'make-delimiter-gestures
449                     (accept ptype :stream s :view view :prompt nil                                        :existing-delimiter-args
450                             :default default))                                        (delimiter-gestures query)
451                 #'(lambda (s)                                        accept-args)))
452                 (accept ptype :stream s :view view :prompt nil)))))      ;; If there was an error on a previous pass, set the insertion pointer to
453      (setf (changedp query) t)))      ;; 0 so the user has a chance to edit the field without causing another
454        ;; error. Otherwise the insertion pointer should already be at the end of
455        ;; the input (because it was activated); perhaps we should set it anyway.
456        (when (accept-condition query)
457          (setf (stream-insertion-pointer estream) 0))
458        (reset-scan-pointer estream)
459        (setf (accept-condition query) nil)
460        ;; If a condition is thrown, then accept should return the old value and
461        ;; ptype.
462        (block accept-condition-handler
463          (setf (changedp query) nil)
464          (setf (values (value query) (ptype query))
465                (input-editing-rescan-loop
466                 estream
467                 #'(lambda (s)
468                     (handler-bind
469                         ((error
470                           #'(lambda (c)
471                               (format *trace-output*
472                                       "accepting-values accept condition: ~A~%"
473                                       c)
474                               (if interactive
475                                   (progn
476                                     (beep)
477                                     (goatee::set-editing-stream-insertion-pointer
478                                      estream
479                                      (1- (stream-scan-pointer estream)))
480                                     (immediate-rescan estream)
481                                     (format *trace-output* "Ack!~%"))
482                                   (progn
483                                     (setf (accept-condition query) c)
484                                     (return-from accept-condition-handler
485                                       c))))))
486                       (goatee::update-input-editing-stream s)
487                       (if default-supplied-p
488                           (accept ptype :stream s
489                                   :view view :prompt nil :default default)
490                           (accept ptype :stream s :view view :prompt nil))))))
491          (setf (changedp query) t))))
492    
493    
494    
495    
# Line 454  is called. Used to determine if any edit Line 498  is called. Used to determine if any edit
498    (declare (ignore stream))    (declare (ignore stream))
499    (let ((estream (editing-stream record))    (let ((estream (editing-stream record))
500          (ptype (ptype query))          (ptype (ptype query))
501          (view (view query))          (view (view query)))
         (accept-args (accept-arguments query)))  
502      (declare (ignore ptype view))       ;for now      (declare (ignore ptype view))       ;for now
503      (let* ((*activation-gestures* (apply #'make-activation-gestures      (with-accessors ((stream-input-buffer stream-input-buffer))
                                          :existing-activation-gestures  
                                          (activation-gestures query)  
                                          accept-args))  
   
            (*delimiter-gestures* (apply #'make-delimiter-gestures  
                                          :existing-delimiter-args  
                                          (delimiter-gestures query)  
                                          accept-args)))  
       (with-accessors ((stream-activated stream-activated)  
                        (stream-input-buffer stream-input-buffer))  
504          estream          estream
505          ;; "deactivate" editing stream if user has previously activated it.        (setf (cursor-visibility estream) t)
506          (when stream-activated        (setf (snapshot record) (copy-seq stream-input-buffer))
507            (setf stream-activated nil)        (av-do-accept query record t))))
           (when (activation-gesture-p (aref stream-input-buffer  
                                             (1- (fill-pointer  
                                                  stream-input-buffer))))  
             (replace-input estream ""  
                            :buffer-start (1- (fill-pointer  
                                               stream-input-buffer))  
                            :rescan t)))  
         (setf (cursor-visibility estream) t)  
         (setf (snapshot record) (copy-seq stream-input-buffer))  
         (block accept-condition-handler  
           (handler-bind ((condition #'(lambda (c)  
                                         (format *trace-output*  
                                                 "accepting-values accept condition: ~A~%"  
                                                 c)  
                                         (setf (accept-condition query) c)  
                                         (return-from accept-condition-handler  
                                           c))))  
             (av-do-accept query record)))))))  
   
508    
509    
510    ;;; If the query has not been changed (i.e., ACCEPT didn't return) and there is
511    ;;; no error, act as if the user activated the query.
512  (defmethod deselect-query (stream query (record av-text-record))  (defmethod deselect-query (stream query (record av-text-record))
513    (let ((estream (editing-stream record)))    (let ((estream (editing-stream record)))
514      (setf (cursor-visibility estream) nil)))      (setf (cursor-visibility estream) nil)
515        (when (not (or (changedp query) (accept-condition query)))
516          (finalize-query-record query record))))
517    
518    
519  (defgeneric finalize-query-record (query record)  (defgeneric finalize-query-record (query record)
520    (:documentation "Do any cleanup on a query before the accepting-values body    (:documentation "Do any cleanup on a query before the accepting-values body
# Line 513  is run for the last time")) Line 532  is run for the last time"))
532    
533  (defmethod finalize-query-record (query (record av-text-record))  (defmethod finalize-query-record (query (record av-text-record))
534    (let ((estream (editing-stream record)))    (let ((estream (editing-stream record)))
535      (when (and (not (stream-activated estream))      (when (and (snapshot record)
                (snapshot record)  
536                 (not (equal (snapshot record)                 (not (equal (snapshot record)
537                             (stream-input-buffer estream))))                             (stream-input-buffer estream))))
538        (let* ((activation-gestures (apply #'make-activation-gestures        (let* ((activation-gestures (apply #'make-activation-gestures
# Line 524  is run for the last time")) Line 542  is run for the last time"))
542               (gesture (car activation-gestures)))               (gesture (car activation-gestures)))
543          (when gesture          (when gesture
544            (let ((c (character-gesture-name gesture)))            (let ((c (character-gesture-name gesture)))
545              (replace-input estream (string c)              (activate-stream estream c)
                            :buffer-start (fill-pointer (stream-input-buffer  
                                                         estream))  
                            :rescan nil)  
             (setf (stream-activated estream) t)  
546              (reset-scan-pointer estream)              (reset-scan-pointer estream)
547              (av-do-accept query record)))))))              (av-do-accept query record nil)))))))
548    
549  (defun finalize-query-records (av-stream)  (defun finalize-query-records (av-stream)
550    (loop for query in (queries av-stream)    (loop for query in (queries av-stream)

Legend:
Removed from v.1.17  
changed lines
  Added in v.1.18

  ViewVC Help
Powered by ViewVC 1.1.5