source: trunk/cocoa-ide-contrib/foy/hemlock-commands-cm/hemlock-documentation-dialog.lisp @ 14985

Last change on this file since 14985 was 14985, checked in by gfoy, 9 years ago

Updates for ccl 1.7

File size: 13.2 KB
Line 
1;;;-*-Mode: LISP; Package: HEMLOCK-COMMANDS -*-
2
3;;; ----------------------------------------------------------------------------
4;;;
5;;;      hemlock-documentation-dialog.lisp
6;;;
7;;;      copyright © 2009 Glen Foy
8;;;      (Permission is granted to Clozure Associates to distribute this file.)
9;;;
10;;;      A documentation dialog for Hemlock commands, CL function, symbols, etc.
11;;;
12;;;      This software is offered "as is", without warranty of any kind.
13;;;
14;;;      Mod History, most recent first:
15;;;      8/31/9  version 0.1b1
16;;;              First cut.
17;;;
18;;; ----------------------------------------------------------------------------
19
20(in-package "HEMLOCK-COMMANDS")
21
22(defParameter *doc-dialog* nil)
23(defParameter *hemlock-jpg* (merge-pathnames ";Hemlock.jpg" cl-user::*hemlock-commands-directory*))
24;;; I don't know the name of the artist who drew this graphic, but it is quite nice.
25;;; I also don't know what the copyright issues are, so this will have to be replaced when I get a chance:
26(defParameter *graphic-p* t "To use, or not to use the eye candy.")
27
28
29;;; ----------------------------------------------------------------------------
30;;;
31(defClass DOC-DIALOG (ns:ns-window)
32  ((name :accessor name)
33   (symbol :accessor symbol)
34   (name-field :accessor name-field)
35   (key-field :accessor key-field)
36   (doc-text-view :accessor doc-text-view)
37   (hemlock-p :initform nil :accessor hemlock-p)
38   (hyperspec-button :accessor hyperspec-button)
39   (inspect-button :accessor inspect-button)
40   (okay-button :accessor okay-button)
41   (source-button :accessor source-button)
42   (text-view :accessor text-view))
43  (:documentation "A dialog for displaying the documentation of Hemlock Commands, CL function, non-CL functions, etc.")
44  (:metaclass ns:+ns-object))
45
46(objc:defmethod (#/closeAction: :void) ((d doc-dialog) (sender :id))
47  (declare (ignore sender))
48  (#/close d))
49
50(objc:defmethod (#/hyperSpecAction: :void) ((d doc-dialog) (sender :id))
51  (declare (ignore sender))
52  (when (symbol d) 
53    (gui::lookup-hyperspec-symbol (symbol d) (text-view d))))
54
55(objc:defmethod (#/inspectSymbolAction: :void) ((d doc-dialog) (sender :id))
56  (declare (ignore sender))
57  (when (symbol d)
58    (inspect (symbol d))))
59
60;;; Should probably just make Hemlock-Commands require List-Definitions:
61#+:list-definitions
62(objc:defmethod (#/commandSourceAction: :void) ((d doc-dialog) (sender :id))
63  (declare (ignore sender))
64  (cond ((hemlock-p d)
65         (let* ((search-string (format nil "(defcommand \"~A\"" (name d)))
66                (hemlock-src-dir (merge-pathnames "cocoa-ide/hemlock/src/" (native-translated-namestring "ccl:")))
67                (files (cons (namestring (merge-pathnames ";hemlock-commands-new.lisp" cl-user::*hemlock-commands-directory*))
68                             (mapcar #'namestring
69                                     (remove-if #'(lambda (path)
70                                                    (string-not-equal (pathname-type path) "lisp"))
71                                                (directory (merge-pathnames hemlock-src-dir "*.lisp") :files t :directories nil)))))
72                (args (cons "-l" (cons search-string files)))
73                (source-path (string-trim '(#\newline #\space) (gui::call-grep args))))
74           (if (and (stringp source-path) (string-not-equal source-path ""))
75             (ldefs:find-and-display-definition (format nil "~S" (name d)) source-path)
76             (cmenu:notify (format nil "Could not find: ~S" (name d))))))
77        (t
78         (hemlock::edit-definition (symbol d)))))
79
80#-:list-definitions
81(objc:defmethod (#/commandSourceAction: :void) ((d doc-dialog) (sender :id))
82  (declare (ignore sender))
83  (cond ((hemlock-p d)
84         ;; deactivate the button instead of this?
85         (gui::alert-window :title "Notification" :message "Searching for source requires the List-Definitions tool."))
86        (t
87         (hemlock::edit-definition (symbol d)))))
88
89
90(defun open-documentation-dialog (name key-or-type doc &key symbol hemlock-p text-view)
91  "Open the dialog displaying the documentation for NAME."
92  (when (null text-view) (setq text-view (get-listener-text-view)))
93  (let* ((name-string (#/initWithString:attributes: (#/alloc ns:ns-attributed-string) 
94                                                   (ccl::%make-nsstring 
95                                                    (if hemlock-p
96                                                      ;; *** ~S
97                                                      (string-upcase (format nil "\"~A\"" name))
98                                                      (format nil "~A" name)))
99                                                   cmenu::*tool-label-dictionary*))
100        (key-string (#/initWithString:attributes: (#/alloc ns:ns-attributed-string) 
101                                                  (if key-or-type
102                                                    (ccl::%make-nsstring key-or-type)
103                                                    (ccl::%make-nsstring " "))
104                                                  cmenu::*tool-key-dictionary*))
105         (inspect-p doc) ; "No documentation found"
106         (source-p (when symbol (ccl::%source-files symbol)))
107         (hyperspec-p (when (and symbol text-view) (gethash symbol (gui::hyperspec-map-hash text-view)))))
108    (cond (*doc-dialog*
109           (cond (hemlock-p
110                  (setf (hemlock-p *doc-dialog*) t)
111                  (#/setTitle: *doc-dialog* #@"Hemlock Command Documentation")
112                  (#/setHidden: (inspect-button *doc-dialog*) t)
113                  (#/setHidden: (hyperspec-button *doc-dialog*) t))
114                 (t
115                  (setf (hemlock-p *doc-dialog*) nil)
116                  (if source-p
117                    (#/setEnabled: (source-button *doc-dialog*) t)
118                    (#/setEnabled: (source-button *doc-dialog*) nil))
119                  (if inspect-p
120                    (#/setEnabled: (inspect-button *doc-dialog*) t)
121                    (#/setEnabled: (inspect-button *doc-dialog*) nil))
122                  (#/setHidden: (hyperspec-button *doc-dialog*) nil)
123                  (#/setHidden: (inspect-button *doc-dialog*) nil)
124                  (#/setTitle: *doc-dialog* #@"Documentation")))
125           (setf (name *doc-dialog*) name)
126           (setf (symbol *doc-dialog*) symbol)
127           (setf (text-view *doc-dialog*) text-view)
128           (if hyperspec-p 
129             (#/setEnabled: (hyperspec-button *doc-dialog*) t)
130             (#/setEnabled: (hyperspec-button *doc-dialog*) nil))
131           ;; (#/setDefaultButtonCell: dialog (okay-button dialog))
132           (#/setStringValue: (name-field *doc-dialog*) name-string)
133           (#/setStringValue: (key-field *doc-dialog*) key-string)
134           (#/setString: (doc-text-view *doc-dialog*) (if doc (ccl::%make-nsstring doc) #@""))
135           (#/makeKeyAndOrderFront: *doc-dialog* nil))
136          (t
137           (let ((dialog (#/alloc doc-dialog)))
138             (setq *doc-dialog* dialog)
139             (ns:with-ns-rect (r 100 100 (if *graphic-p* 625 475) 230)
140               (#/initWithContentRect:styleMask:backing:defer: 
141                dialog
142                r
143                (logior  #$NSTitledWindowMask 
144                         #$NSClosableWindowMask 
145                         #$NSMiniaturizableWindowMask)
146                #$NSBackingStoreBuffered
147                #$NO))
148             (dolist (item (get-items dialog))
149               (#/addSubview: (#/contentView dialog) item))
150             (cond (hemlock-p
151                  (setf (hemlock-p dialog) t)
152                  (#/setTitle: dialog #@"Hemlock Command Documentation")
153                  (#/setHidden: (inspect-button dialog) t)
154                  (#/setHidden: (hyperspec-button dialog) t))
155                 (t
156                  (setf (hemlock-p dialog) nil)
157                  (if source-p
158                    (#/setEnabled: (source-button dialog) t)
159                    (#/setEnabled: (source-button dialog) nil))
160                  (if inspect-p
161                    (#/setEnabled: (inspect-button *doc-dialog*) t)
162                    (#/setEnabled: (inspect-button *doc-dialog*) nil))
163                  (#/setHidden: (hyperspec-button dialog) nil)
164                  (#/setHidden: (inspect-button dialog) nil)
165                  (#/setTitle: dialog #@"Documentation")))
166             (if hyperspec-p 
167               (#/setEnabled: (hyperspec-button *doc-dialog*) t)
168               (#/setEnabled: (hyperspec-button *doc-dialog*) nil))
169             (#/setReleasedWhenClosed: dialog nil)
170             (#/setDefaultButtonCell: dialog (okay-button dialog))
171             (#/center dialog)
172             (#/setStringValue: (name-field dialog) name-string)
173             (#/setStringValue: (key-field dialog) key-string)
174             (#/setString: (doc-text-view dialog) (if doc (ccl::%make-nsstring doc) #@""))
175             (setf (name dialog) name)
176             (setf (symbol dialog) symbol)
177             (setf (text-view dialog) text-view)
178             (#/makeKeyAndOrderFront: dialog nil))))))
179
180;;; This is a redefintion of the function in cl-documentation-1.lisp
181(defun cldoc::display-cl-doc (sym text-view)
182  "If there is CCL or MCL doc, use the doc-dialog to display documentation.  Otherwise use the HyperSpec."
183  (when (eq (symbol-package sym) (find-package :common-lisp))
184    (or (display-ccl-doc sym text-view)
185        (display-mcl-doc sym text-view)
186        (gui::lookup-hyperspec-symbol sym text-view))))
187
188(defun get-listener-text-view ()
189  "If the menu is installed under the Help Menu, there is no text-view.  Borrow the Listener text-view."
190  (let* ((listeners (gui::active-listener-windows))
191         (listener (first listeners)))
192    (when listener
193      (slot-value (slot-value listener 'gui::pane) 'gui::text-view))))
194
195(defMethod get-items ((d doc-dialog))
196  (append
197   (when *graphic-p* 
198     (make-hemlock-image))
199   (make-name-field d)
200   (make-key-field d)
201   (make-doc-text-view d)
202   (make-buttons d)))
203
204(defun make-hemlock-image ()
205  "Create the Hemlock graphic.  You can make this go away by set *graphic-p* to nil above."
206  (let ((image (#/alloc ns:ns-image))
207        (image-view (#/alloc ns:ns-image-view)))
208    (ns:with-ns-rect (frame 10 54 141 164)
209      (#/initWithFrame: image-view frame))
210    (#/initWithContentsOfFile: image (ccl::%make-nsstring (namestring *hemlock-jpg*)))
211    (#/setImage: image-view image)
212    (list image-view)))
213
214(defun make-name-field (dialog)
215  "Create the name text-field."
216  (list
217   (let* ((title (#/alloc ns:ns-text-field)))
218     (ns:with-ns-rect (frame (if *graphic-p* 165 15) 178 440 38)
219       (#/initWithFrame: title frame))
220     (#/setEditable: title nil)
221     (#/setDrawsBackground: title nil)
222     (#/setBordered: title nil)
223     (#/setStringValue: title #@"")
224     (setf (name-field dialog) title))))
225
226(defun make-key-field (dialog)
227  "Create the key text-field."
228  (list
229   (let* ((title (#/alloc ns:ns-text-field)))
230     (ns:with-ns-rect (frame (if *graphic-p* 165 15) 162 450 16)
231       (#/initWithFrame: title frame))
232     (#/setEditable: title nil)
233     (#/setDrawsBackground: title nil)
234     (#/setBordered: title nil)
235     (#/setStringValue: title #@"")
236     (setf (key-field dialog) title))))
237
238(defun make-doc-text-view (dialog)
239  "Create the documentation text-view."
240  (list
241   (let* ((scroll-view (#/alloc ns:ns-scroll-view))
242          (view (#/init (#/alloc ns:ns-text-view))))
243     (ns:with-ns-rect (frame (if *graphic-p* 165 15) 54 460 106)
244       (#/initWithFrame: scroll-view frame))
245     (ns:with-ns-rect (frame 4 60 445 200)
246       (#/initWithFrame: view frame))
247     (#/setString: view #@" ")
248     (#/setHasVerticalScroller: scroll-view t)
249     (#/setHasHorizontalScroller: scroll-view nil)
250     (#/setBorderType: scroll-view #$NSBezelBorder)
251     (#/setDocumentView: scroll-view view)
252     (#/setEditable: view nil)
253     (#/setFont: view (#/systemFontOfSize: ns:ns-font (#/smallSystemFontSize ns:ns-font)))
254     (#/setTextColor: view cmenu:*dark-turquoise-color*)
255     (#/setBackgroundColor: view cmenu:*light-gray-color*)
256     (setf (doc-text-view dialog) view)
257     scroll-view)))
258
259
260(defun make-buttons (dialog)
261  "Construct the buttons."
262  (flet ((make-button (title x-coord y-coord x-dim y-dim action)
263           (let ((button (#/alloc ns:ns-button)))
264             (ns:with-ns-rect (frame x-coord y-coord x-dim y-dim)
265               (#/initWithFrame: button frame))
266             (#/setButtonType: button #$NSMomentaryPushInButton)
267             ; (#/setImagePosition: button #$NSNoImage)
268             (#/setBezelStyle: button #$NSRoundedBezelStyle)
269             (#/setTitle: button title)
270             (#/setTarget: button dialog)
271             (#/setAction: button action)
272             button)))
273    (list
274     (setf (okay-button dialog)
275           (make-button #@"Okay" (if *graphic-p* 520 370) 10 80 32
276                        (ccl::@selector "closeAction:")))
277     (setf (source-button dialog)
278           (make-button #@"Source..." (if *graphic-p* 420 270) 10 90 32
279                        (ccl::@selector "commandSourceAction:")))
280     (setf (inspect-button dialog)
281           (make-button #@"Inspect..." (if *graphic-p* 320 170) 10 90 32
282                        (ccl::@selector "inspectSymbolAction:")))
283     (setf (hyperspec-button dialog)
284           (make-button #@"HyperSpec..." (if *graphic-p* 180 30) 10 130 32
285                        (ccl::@selector "hyperSpecAction:"))))))
286
287
288
289
290
291
Note: See TracBrowser for help on using the repository browser.