source: trunk/source/contrib/foy/context-menu-cm/context-menu-dialogs.lisp @ 12802

Last change on this file since 12802 was 12802, checked in by gfoy, 10 years ago

Snazzy new notification dialog, I think.

File size: 6.9 KB
Line 
1;;; ----------------------------------------------------------------------------
2;;;
3;;;      context-menu-dialogs.lisp
4;;;
5;;;      copyright (c) 2009 Glen Foy
6;;;      (Permission is granted to Clozure Associates to distribute this file.)
7;;;
8;;;      Utilities and dialogs for the Context-Menu tool set.
9;;;
10;;;      The API for writing new tools is described in the accompanying NewTools file.
11;;;
12;;;      This software is offered "as is", without warranty of any kind.
13;;;
14;;;      Mod History, most recent first:
15;;;      9/14/9  First cut
16;;;
17;;; ----------------------------------------------------------------------------
18
19(defpackage "CONTEXT-MENU" (:nicknames "CMENU") (:use :cl :ccl))
20(in-package "CONTEXT-MENU")
21
22(export '(notify window-with-path active-hemlock-window window-path echo-msg))
23
24(defparameter *clozure-jpg* (merge-pathnames ";Clozure.jpg" cl-user::*context-menu-directory*))
25(defparameter *graphic-p* t "To use, or not to use the Clozure graphic.")
26
27
28(defun active-hemlock-window ()
29  "Return the active hemlock-frame."
30  (gui::first-window-satisfying-predicate 
31   #'(lambda (w)
32       (and (typep w 'gui::hemlock-frame)
33            (not (typep w 'gui::hemlock-listener-frame))
34            (#/isKeyWindow w)))))
35
36(defun window-path (w)
37  "Return the window's path."
38  (let* ((pane (slot-value w 'gui::pane))
39         (hemlock-view (when pane (gui::text-pane-hemlock-view pane)))
40         (buffer (when hemlock-view (hi::hemlock-view-buffer hemlock-view))))
41    (when buffer (hi::buffer-pathname buffer))))
42
43;;; This includes a work-around for what appears to be a bug in the hemlock-frame
44;;; #/close method.  After a #/close, the window remains on the (#/orderedWindows *NSApp*)
45;;; list, but (hi::buffer-document buffer) in NIL.  Therefore the extra tests:
46(defun window-with-path (path)
47  "If a window with PATH is open, return it."
48  (gui::first-window-satisfying-predicate 
49   #'(lambda (w)
50       (when (and (typep w 'gui::hemlock-frame)
51                  (not (typep w 'gui::hemlock-listener-frame)))
52         (let* ((pane (slot-value w 'gui::pane))
53                (text-view (gui::text-pane-text-view pane))
54                (buffer (gui::hemlock-buffer text-view))
55                (document (when buffer (hi::buffer-document buffer)))
56                (p (hi::buffer-pathname buffer)))
57           (when (and document p) (string-equal path p)))))))
58
59(defun echo-msg (string &rest args)
60  (let* ((window (cmenu:active-hemlock-window))
61         (hemlock-view (when window (gui::hemlock-view window))))
62    (when hemlock-view
63      (let ((hi::*current-view* hemlock-view))
64        (hi::message string args)))))
65
66(defun notify (message &rest args)
67  "FYI"
68  (let ((message-string (apply #'format nil message args)))
69    (if *graphic-p*
70      (open-notification-dialog message-string)
71      (gui::alert-window :title "Notification" :message message-string))))
72
73(defparameter *notify-dialog* nil "The notification-dialog instance.")
74
75;;; ----------------------------------------------------------------------------
76;;;
77(defclass NOTIFICATION-DIALOG (ns:ns-window)
78  ((message-field :initform nil :accessor nd-message-field)
79   (okay-button :initform nil :accessor nd-okay-button))
80  (:documentation "A dialog for displaying messages.")
81  (:metaclass ns:+ns-object))
82
83(objc:defmethod (#/okayAction: :void) ((d notification-dialog) (sender :id))
84  (declare (ignore sender))
85  (#/stopModalWithCode: ccl::*nsapp* 0))
86
87(defun open-notification-dialog (message)
88  "Open the notification-dialog and display MESSAGE."
89  (let ((message-string (#/initWithString:attributes: (#/alloc ns:ns-attributed-string) 
90                                                      (ccl::%make-nsstring message)
91                                                      cmenu::*tool-doc-dictionary*)))
92    (cond (*notify-dialog*
93           (#/setStringValue: (nd-message-field *notify-dialog*) message-string)
94           (#/makeKeyAndOrderFront: *notify-dialog* nil)
95           (#/runModalForWindow: ccl::*nsapp* *notify-dialog*)
96           (#/close *notify-dialog*))
97          (t
98           (let ((dialog (#/alloc notification-dialog)))
99             (setq *notify-dialog* dialog)
100             (ns:with-ns-rect (r 10 300 400 127)
101               (#/initWithContentRect:styleMask:backing:defer: 
102                dialog
103                r
104                #$NSTitledWindowMask 
105                #$NSBackingStoreBuffered
106                #$NO))
107             (dolist (item (get-notify-items dialog))
108               (#/addSubview: (#/contentView dialog) item))
109             (#/setTitle: dialog #@"Notification")
110             (#/setReleasedWhenClosed: dialog nil)
111             (#/setDefaultButtonCell: dialog (nd-okay-button dialog))
112             (#/setStringValue: (nd-message-field dialog) message-string)
113             (#/center dialog)
114             (#/makeKeyAndOrderFront: dialog nil)
115             (#/runModalForWindow: ccl::*nsapp* dialog)
116             (#/close dialog))))))
117
118#|
119(open-notification-dialog "foobear")
120|#
121
122(defmethod get-notify-items ((d notification-dialog))
123  (append
124   (make-notify-graphic)
125   ;; (make-notify-prompt)
126   (make-notify-message d)
127   (make-notify-button d)))
128
129(defun make-notify-graphic ()
130  "Create the Clozure graphic."
131  (when (probe-file *clozure-jpg*)
132    (let ((image (#/alloc ns:ns-image))
133          (image-view (#/alloc ns:ns-image-view)))
134      (ns:with-ns-rect (frame 0 0 108 127)
135        (#/initWithFrame: image-view frame))
136      (#/setImageScaling: image-view #$NSScaleToFit)
137      (#/initWithContentsOfFile: image (ccl::%make-nsstring (namestring *clozure-jpg*)))
138      (#/setImage: image-view image)
139      (list image-view))))
140
141(defun make-notify-prompt ()
142  "Create the prompt text-field."
143  (list
144   (let* ((string (#/initWithString:attributes: 
145                   (#/alloc ns:ns-attributed-string) 
146                   #@"Notification"
147                   cmenu::*tool-label-dictionary*))
148          (title (#/alloc ns:ns-text-field)))
149     (ns:with-ns-rect (frame 120 90 150 32)
150       (#/initWithFrame: title frame))
151     (#/setEditable: title nil)
152     (#/setDrawsBackground: title nil)
153     (#/setBordered: title nil)
154     (#/setStringValue: title string)
155     title)))
156
157(defun make-notify-message (dialog)
158  "Create the documentation text-view."
159  (list
160   (let ((field (#/alloc ns:ns-text-field)))
161     (ns:with-ns-rect (frame 120 50 270 60)
162       (#/initWithFrame: field frame))
163     (#/setEditable: field nil)
164     (#/setDrawsBackground: field nil)
165     (#/setBordered: field nil)
166     (setf (nd-message-field dialog) field))))
167
168(defun make-notify-button (dialog)
169  "Construct the button."
170  (list
171   (let ((button (#/alloc ns:ns-button)))
172     (ns:with-ns-rect (frame 310 10 80 32)
173       (#/initWithFrame: button frame))
174     (#/setButtonType: button #$NSMomentaryPushInButton)
175     (#/setBezelStyle: button #$NSRoundedBezelStyle)
176     (#/setTitle: button #@"Okay")
177     (#/setTarget: button dialog)
178     (#/setAction: button (ccl::@selector "okayAction:"))
179     (setf (nd-okay-button dialog) button))))
180
181
182
183
184
Note: See TracBrowser for help on using the repository browser.