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

Diff of /mcclim/dialog.lisp

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

revision 1.26 by thenriksen, Tue May 29 12:34:20 2007 UTC revision 1.27 by ahefner, Wed Jun 6 05:03:12 2007 UTC
# Line 622  is run for the last time")) Line 622  is run for the last time"))
622  (defun accepting-values-default-command ()  (defun accepting-values-default-command ()
623    (loop    (loop
624     (read-gesture :stream *accepting-values-stream*)))     (read-gesture :stream *accepting-values-stream*)))
625    
626    
627    ;;;; notify-user
628    
629    ;;; See http://openmap.bbn.com/hypermail/clim/0028.html for example usage.
630    
631    ;;; TODO:
632    ;;;   - associated-window argument?
633    ;;;   - What is the correct return value from notify-user? We currently return
634    ;;;     the name of the action given in the :exit-boxes argument.
635    ;;;   - Invoke abort restart? Not necessary as it is with accepting-values,
636    ;;;     but probably what "Classic CLIM" does.
637    ;;;   - What are the default exit boxes? Just "Okay"? Okay and cancel?
638    ;;;   - Reimplement using accepting-values, if accepting-values is ever
639    ;;;     improved to produce comparable dialogs.
640    ;;;   - Should the user really be able to close the window from the WM?
641    
642    (defmethod notify-user (frame message &rest args)
643      (apply #'frame-manager-notify-user
644             (if frame (frame-manager frame) (find-frame-manager))
645             message
646             :frame frame
647             args))
648    
649    (define-application-frame generic-notify-user-frame ()
650      ((message-string :initarg :message-string)
651       (exit-boxes :initarg :exit-boxes)
652       (title :initarg :title)
653       (style :initarg :style)
654       (text-style :initarg :text-style)
655       (return-value :initarg nil :initform :abort))
656      (:pane (generate-notify-user-dialog *application-frame*)))
657    
658    (defun generate-notify-user-dialog (frame)
659      (with-slots (message-string exit-boxes text-style) frame
660      (vertically ()
661        (spacing (:thickness 6)
662          (make-pane 'label-pane :label (or message-string "I'm speechless.") :text-style text-style))
663        (spacing (:thickness 4)
664          (make-pane 'hbox-pane :contents (cons '+fill+ (generate-exit-box-buttons exit-boxes)))))))
665    
666    (defun generate-exit-box-buttons (specs)
667      (mapcar
668       (lambda (spec)
669         (destructuring-bind (action string &rest args) spec
670           (spacing (:thickness 2)
671             (apply #'make-pane
672                    'push-button
673                    :label string
674                    :text-style (make-text-style :sans-serif :roman :small) ; XXX
675                    :activate-callback
676                    (lambda (gadget)
677                      (declare (ignore gadget))
678                      ;; This is fboundp business is weird, and only implied by a
679                      ;; random message on the old CLIM list. Does the user function
680                      ;; take arguments?
681                      (when (or (typep action 'function) (fboundp action))
682                        (funcall action))
683                      (setf (slot-value *application-frame* 'return-value) action)
684                      ;; This doesn't work:
685                      #+NIL
686                      (when (eql action :abort)
687                        (and (find-restart 'abort)
688                             (invoke-restart 'abort)))
689                      (frame-exit *application-frame*))
690                    args))))
691       specs))
692    
693    
694    (defmethod frame-manager-notify-user
695        (frame-manager message-string &key frame associated-window
696                       (title "")
697                       documentation
698                       (exit-boxes '((:exit "OK")))
699                       ; The 'name' arg is in the spec but absent from the Lispworks
700                       ; manual, and I can't imagine what it would do differently
701                       ; than 'title'.
702                       name
703                       style
704                       (text-style (make-text-style :sans-serif :roman :small)))
705      (declare (ignore associated-window documentation))
706      ;; Keywords from notify-user:
707      ;; associated-window title documentation exit-boxes name style text-style
708      (let ((frame (make-application-frame 'generic-notify-user-frame
709                                           :frame-event-queue (and frame (frame-event-queue frame))
710                                           :pretty-name title
711                                           :message-string message-string
712                                           :frame-manager frame-manager
713                                           :exit-boxes exit-boxes
714                                           :title (or name title)
715                                           :style style
716                                           :text-style text-style)))
717        (run-frame-top-level frame)
718        (slot-value frame 'return-value)))

Legend:
Removed from v.1.26  
changed lines
  Added in v.1.27

  ViewVC Help
Powered by ViewVC 1.1.5