[mcclim-cvs] CVS mcclim

[ahefner]

Update of /project/mcclim/cvsroot/mcclim
In directory clnet:/tmp/cvs-serv4237

Modified Files:
	dialog.lisp 
Log Message:
Committing some old work: implementation of notify-user, with some 
uncertainty as to how it works in classic CLIM.


--- /project/mcclim/cvsroot/mcclim/dialog.lisp	2007/05/29 12:34:20	1.26
+++ /project/mcclim/cvsroot/mcclim/dialog.lisp	2007/06/06 05:03:12	1.27
@@ -622,3 +622,97 @@
 (defun accepting-values-default-command ()
   (loop
    (read-gesture :stream *accepting-values-stream*)))
+
+
+;;;; notify-user
+
+;;; See http://openmap.bbn.com/hypermail/clim/0028.html for example usage.
+
+;;; TODO:
+;;;   - associated-window argument?
+;;;   - What is the correct return value from notify-user? We currently return
+;;;     the name of the action given in the :exit-boxes argument.
+;;;   - Invoke abort restart? Not necessary as it is with accepting-values,
+;;;     but probably what "Classic CLIM" does.
+;;;   - What are the default exit boxes? Just "Okay"? Okay and cancel?
+;;;   - Reimplement using accepting-values, if accepting-values is ever
+;;;     improved to produce comparable dialogs.
+;;;   - Should the user really be able to close the window from the WM?
+
+(defmethod notify-user (frame message &rest args)
+  (apply #'frame-manager-notify-user
+	 (if frame (frame-manager frame) (find-frame-manager))
+	 message
+	 :frame frame
+	 args))
+
+(define-application-frame generic-notify-user-frame ()
+  ((message-string :initarg :message-string)
+   (exit-boxes :initarg :exit-boxes)
+   (title :initarg :title)
+   (style :initarg :style)
+   (text-style :initarg :text-style)
+   (return-value :initarg nil :initform :abort))
+  (:pane (generate-notify-user-dialog *application-frame*)))
+
+(defun generate-notify-user-dialog (frame)
+  (with-slots (message-string exit-boxes text-style) frame
+  (vertically ()
+    (spacing (:thickness 6)
+      (make-pane 'label-pane :label (or message-string "I'm speechless.") :text-style text-style))
+    (spacing (:thickness 4)
+      (make-pane 'hbox-pane :contents (cons '+fill+ (generate-exit-box-buttons exit-boxes)))))))
+
+(defun generate-exit-box-buttons (specs)
+  (mapcar
+   (lambda (spec)
+     (destructuring-bind (action string &rest args) spec
+       (spacing (:thickness 2)
+         (apply #'make-pane
+                'push-button
+                :label string
+                :text-style (make-text-style :sans-serif :roman :small) ; XXX
+                :activate-callback
+                (lambda (gadget)
+                  (declare (ignore gadget))
+                  ;; This is fboundp business is weird, and only implied by a 
+                  ;; random message on the old CLIM list. Does the user function
+                  ;; take arguments?
+                  (when (or (typep action 'function) (fboundp action))
+                    (funcall action))
+                  (setf (slot-value *application-frame* 'return-value) action)
+                  ;; This doesn't work:
+                  #+NIL 
+                  (when (eql action :abort)
+                    (and (find-restart 'abort)
+                         (invoke-restart 'abort)))
+                  (frame-exit *application-frame*))
+                args))))
+   specs))
+
+		  
+(defmethod frame-manager-notify-user 
+    (frame-manager message-string &key frame associated-window
+		   (title "")
+		   documentation
+		   (exit-boxes '((:exit "OK")))
+		   ; The 'name' arg is in the spec but absent from the Lispworks
+		   ; manual, and I can't imagine what it would do differently
+		   ; than 'title'.
+		   name
+		   style
+		   (text-style (make-text-style :sans-serif :roman :small)))
+  (declare (ignore associated-window documentation))
+  ;; Keywords from notify-user:
+  ;; associated-window title documentation exit-boxes name style text-style
+  (let ((frame (make-application-frame 'generic-notify-user-frame
+                                       :frame-event-queue (and frame (frame-event-queue frame))
+                                       :pretty-name title
+                                       :message-string message-string
+                                       :frame-manager frame-manager
+                                       :exit-boxes exit-boxes
+                                       :title (or name title)
+                                       :style style
+                                       :text-style text-style)))
+    (run-frame-top-level frame)
+    (slot-value frame 'return-value)))