source: trunk/source/contrib/foy/list-definitions-cm/list-definitions.lisp @ 12735

Last change on this file since 12735 was 12735, checked in by gfoy, 11 years ago

Changed the appearance of the Default Tool submenu and added an alphabetical index to CL-Documentation-CM

File size: 21.9 KB
Line 
1;;;-*-Mode: LISP; Package: LIST-DEFINITIONS -*-
2
3;;; ----------------------------------------------------------------------------
4;;;
5;;;      list-definitionsisp
6;;;
7;;;      copyright (c) 2009 Glen Foy
8;;;      (Permission is granted to Clozure Associates to distribute this file.)
9;;;
10;;;      This code adds a dynamic contextual popup menu to Hemlock.
11;;;
12;;;      Right-Click produces an alphabetized listing of the file's definitions. 
13;;;      Command-Right-Click produces a positional listing.
14;;;
15;;;      This software is offered "as is", without warranty of any kind.
16;;;
17;;;      Mod History, most recent first:
18;;;      8/31/9  version 0.2b2
19;;;              Modified to work with Context-Menu mechanism.
20;;;              Numerous interface suggestions, Rainer Joswig.
21;;;      8/17/9  version 0.2b1
22;;;              Added position history list and file history list.
23;;;      8/12/9  version 0.1b3
24;;;              Numerous interface suggestions, Alexander Repenning.
25;;;      8/10/9  version 0.1b1
26;;;              First cut.
27;;;
28;;; ----------------------------------------------------------------------------
29
30(defpackage "LIST-DEFINITIONS" (:nicknames "LDEFS") (:use :cl :ccl))
31(in-package "LIST-DEFINITIONS")
32
33(require :context-menu-cm)
34
35(export '(find-and-display-definition))
36
37(defParameter *objc-defmethod-search-pattern* (hi::new-search-pattern :string-insensitive :forward "(objc:defmethod"))
38(defParameter *def-search-pattern* (hi::new-search-pattern :string-insensitive :forward "(def"))
39(defParameter *left-paren-search-pattern* (hi::new-search-pattern :character :forward #\())
40(defParameter *colon-search-pattern* (hi::new-search-pattern :character :forward #\:))
41(defParameter *slash-search-pattern* (hi::new-search-pattern :character :forward #\/))
42
43(defVar *position-history-list* nil "The position-history-list instance.")
44(defVar *file-history-list* nil "The file-history-list instance.")
45
46(defmacro clone (mark) `(hi::copy-mark ,mark :temporary))
47
48(defun active-hemlock-window ()
49  "Return the active hemlock-frame."
50  (gui::first-window-satisfying-predicate 
51   #'(lambda (w)
52       (and (typep w 'gui::hemlock-frame)
53            (not (typep w 'gui::hemlock-listener-frame))
54            (#/isKeyWindow w)))))
55
56(defun window-path (w)
57  "Return the window's path."
58  (let* ((pane (slot-value w 'gui::pane))
59         (hemlock-view (when pane (gui::text-pane-hemlock-view pane)))
60         (buffer (when hemlock-view (hi::hemlock-view-buffer hemlock-view))))
61    (when buffer (hi::buffer-pathname buffer))))
62
63;;; ----------------------------------------------------------------------------
64;;;
65(defclass list-definitions-menu (ns:ns-menu)
66  ((text-view :initarg :menu-text-view :reader menu-text-view)
67   (path :initarg :menu-path :reader menu-path) ; *** history-path
68   (doc-path :initform (merge-pathnames ";ReadMe.rtf" cl-user::*list-definitions-directory-string*) :reader doc-path)
69   (tool-menu :initform nil :accessor tool-menu)
70   (sub-title :initform nil :initarg :sub-title :reader sub-title))
71  (:documentation "The definitions popup menu.")
72  (:metaclass ns:+ns-object))
73
74(objc:defmethod (#/listDefinitionsAction: :void) ((m list-definitions-menu) (sender :id))
75  (display-position (menu-text-view m) (item-mark sender))
76  (maybe-add-history-entry *position-history-list* (item-info sender) (menu-path m)))
77
78 (objc:defmethod (#/update :void) ((self list-definitions-menu))
79  (cmenu:update-tool-menu self (tool-menu self) :sub-title (sub-title self))
80  (call-next-method))
81
82(defun display-position (text-view mark)
83  "Display the position of MARK in TEXT-VIEW."
84  (let* ((def-pos (hi::mark-absolute-position mark))
85         (def-end-pos (let ((temp-mark (clone mark)))
86                        (when (hemlock::form-offset temp-mark 1)
87                          (hi::mark-absolute-position temp-mark)))))
88    (unless def-end-pos (when def-pos (setq def-end-pos (1+ def-pos))))
89    (when (and def-pos def-end-pos)
90      (ns:with-ns-range (range def-pos (- def-end-pos def-pos))
91        (#/scrollRangeToVisible: text-view range))
92      (hi::move-mark (hi::buffer-point (gui::hemlock-buffer text-view)) mark)
93      (gui::update-paren-highlight text-view))))
94
95;;; ----------------------------------------------------------------------------
96;;;
97(defclass list-definitions-menu-item (ns:ns-menu-item)
98  ((mark :accessor item-mark)
99   (path :accessor item-path)
100   (info :accessor item-info))
101  (:documentation "Support for the definitions list menu.")
102  (:metaclass ns:+ns-object))
103
104(defparameter *dark-blue-color* (#/colorWithCalibratedRed:green:blue:alpha: ns:ns-color 0.2 0.2 0.5 1.0))
105(defparameter *dark-green-color* (#/colorWithCalibratedRed:green:blue:alpha: ns:ns-color 0.0 0.3 0.1 1.0))
106(defparameter *dark-gray-color* (#/colorWithCalibratedRed:green:blue:alpha: ns:ns-color 0.1 0.1 0.1 1.0))
107(defparameter *dark-brown-color* (#/colorWithCalibratedRed:green:blue:alpha: ns:ns-color 0.3 0.05 0.0 1.0))
108(defparameter *dark-turquoise-color* (#/colorWithCalibratedRed:green:blue:alpha: ns:ns-color 0.0 0.2 0.3 1.0))
109(defparameter *wine-red-color* (#/colorWithCalibratedRed:green:blue:alpha: ns:ns-color 0.4 0.1 0.2 1.0))
110
111(defparameter *generic-dictionary* (make-instance 'ns:ns-mutable-dictionary :with-capacity 2))
112(#/setObject:forKey: *generic-dictionary* (#/systemFontOfSize: ns:ns-font (#/smallSystemFontSize ns:ns-font)) #&NSFontAttributeName)
113(#/setObject:forKey: *generic-dictionary* *dark-gray-color* #&NSForegroundColorAttributeName)
114
115(defparameter *file-history-dictionary* (make-instance 'ns:ns-mutable-dictionary :with-capacity 2))
116(#/setObject:forKey: *file-history-dictionary* (#/systemFontOfSize: ns:ns-font (#/smallSystemFontSize ns:ns-font)) #&NSFontAttributeName)
117(#/setObject:forKey: *file-history-dictionary* *dark-blue-color* #&NSForegroundColorAttributeName)
118
119(defparameter *defclass-dictionary* (make-instance 'ns:ns-mutable-dictionary :with-capacity 3))
120(#/setObject:forKey: *defclass-dictionary* (#/systemFontOfSize: ns:ns-font (#/smallSystemFontSize ns:ns-font)) #&NSFontAttributeName)
121(#/setObject:forKey: *defclass-dictionary* *wine-red-color* #&NSForegroundColorAttributeName)
122(#/setObject:forKey: *defclass-dictionary* (#/numberWithInt: ns:ns-number 1) #&NSUnderlineStyleAttributeName)
123
124(defparameter *defstruct-dictionary* (make-instance 'ns:ns-mutable-dictionary :with-capacity 3))
125(#/setObject:forKey: *defstruct-dictionary* (#/systemFontOfSize: ns:ns-font (#/smallSystemFontSize ns:ns-font)) #&NSFontAttributeName)
126(#/setObject:forKey: *defstruct-dictionary* *dark-turquoise-color* #&NSForegroundColorAttributeName)
127(#/setObject:forKey: *defstruct-dictionary* (#/numberWithInt: ns:ns-number 1) #&NSUnderlineStyleAttributeName)
128
129(defparameter *defmethod-dictionary* (make-instance 'ns:ns-mutable-dictionary :with-capacity 2))
130(#/setObject:forKey: *defmethod-dictionary* (#/systemFontOfSize: ns:ns-font (#/smallSystemFontSize ns:ns-font)) #&NSFontAttributeName)
131(#/setObject:forKey: *defmethod-dictionary* *dark-blue-color* #&NSForegroundColorAttributeName)
132
133(defparameter *defun-dictionary* (make-instance 'ns:ns-mutable-dictionary :with-capacity 2))
134(#/setObject:forKey: *defun-dictionary* (#/systemFontOfSize: ns:ns-font (#/smallSystemFontSize ns:ns-font)) #&NSFontAttributeName)
135(#/setObject:forKey: *defun-dictionary* *dark-green-color* #&NSForegroundColorAttributeName)
136
137(defparameter *defmacro-dictionary* (make-instance 'ns:ns-mutable-dictionary :with-capacity 2))
138(#/setObject:forKey: *defmacro-dictionary* (#/systemFontOfSize: ns:ns-font (#/smallSystemFontSize ns:ns-font)) #&NSFontAttributeName)
139(#/setObject:forKey: *defmacro-dictionary* *dark-brown-color* #&NSForegroundColorAttributeName)
140
141(defparameter *objc-dictionary* (make-instance 'ns:ns-mutable-dictionary :with-capacity 2))
142(#/setObject:forKey: *objc-dictionary* (#/systemFontOfSize: ns:ns-font (#/smallSystemFontSize ns:ns-font)) #&NSFontAttributeName)
143(#/setObject:forKey: *objc-dictionary* *dark-blue-color* #&NSForegroundColorAttributeName)
144
145;;; This is not retained -- assumming autorelease.
146(defun list-definitions-context-menu (text-view &optional alpha-p)
147  "Construct the list-definitions popup menu."
148  (let* ((menu (make-instance 'list-definitions-menu 
149                 :sub-title (if alpha-p "alphabetical" "positional")
150                 :menu-text-view text-view 
151                 :menu-path (window-path (#/window text-view))))
152         (window (active-hemlock-window))
153         (alist (when window (list-definitions window alpha-p)))
154         (class-icon (#/iconForFileType: (#/sharedWorkspace ns:ns-workspace) (ccl::%make-nsstring "lisp")))
155         current-class menu-item)
156    (ns:with-ns-size (icon-size 16 16)
157      (#/setSize: class-icon icon-size))
158    (setf (tool-menu menu) 
159          (if alpha-p
160            (cmenu:add-default-tool-menu menu :doc-file (doc-path menu))
161            (cmenu:add-default-tool-menu menu)))
162    (dolist (entry alist)
163      (let* ((def-info (car entry))
164             (def-type (first def-info))
165             (name (second def-info))
166             (signature (third def-info))
167             (specializer (fourth def-info))
168             (dictionary (case def-type
169                           (:defclass *defclass-dictionary*)
170                           (:defstruct *defstruct-dictionary*)
171                           (:defmethod *defmethod-dictionary*)
172                           (:defun *defun-dictionary*)
173                           (:defmacro *defmacro-dictionary*)
174                           (:objc *objc-dictionary*)
175                           (t *generic-dictionary*)))
176             (attributed-string (#/initWithString:attributes:
177                                 (#/alloc ns:ns-attributed-string) 
178                                 ;; indent methods if directly under specializing class or struct:
179                                 (if (or (eq def-type :defmethod)
180                                         (eq def-type :objc))
181                                   (if (and (not alpha-p)
182                                            current-class specializer
183                                            (string-equal specializer current-class))
184                                     (ccl::%make-nsstring (format nil "      ~A" signature))
185                                     (ccl::%make-nsstring (format nil "~A" signature)))
186                                   (ccl::%make-nsstring name))
187                                 dictionary)))
188        (when (or (eq def-type :defclass) (eq def-type :defstruct)) (setq current-class name))
189        (setq menu-item (make-instance 'list-definitions-menu-item))
190        (setf (item-mark menu-item) (cdr entry))
191        (setf (item-info menu-item) def-info)
192        (#/setAttributedTitle: menu-item attributed-string)
193        ;; Prepend CCL icon to class names:
194        (when (eq def-type :defclass) (#/setImage: menu-item class-icon))
195        (#/setAction: menu-item (ccl::@selector "listDefinitionsAction:"))
196        (#/setTarget: menu-item  menu)
197        (#/addItem: menu menu-item)))
198    menu))
199
200(defun get-list-definitions-menu (view event)
201  (let ((view-window (#/window view)))
202    (#/makeKeyAndOrderFront: view-window nil)
203    (if (logtest #$NSAlternateKeyMask (#/modifierFlags event))
204      (if (logtest #$NSCommandKeyMask (#/modifierFlags event))
205        (files-context-menu)
206        (positions-context-menu))
207      (if (logtest #$NSCommandKeyMask (#/modifierFlags event))
208        (list-definitions-context-menu view nil)
209        (list-definitions-context-menu view t)))))
210
211;;; This includes definitions in sharp-stroke comments.  We'll claim it's a feature.
212(defun list-definitions (hemlock &optional alpha-p)
213  "Create a list of all the top-level definitions in the file."
214  (labels ((get-name (entry)
215             (let ((def-info (car entry)))
216               (second def-info)))
217           (get-defs (mark pattern &optional objc-p)
218             (do ((def-found-p (hi::find-pattern mark pattern)
219                               (hi::find-pattern mark pattern))
220                  alist)
221                 ((not def-found-p) (when alist
222                                      (if alpha-p 
223                                        (sort alist #'string-lessp :key #'get-name) 
224                                        (nreverse alist))))
225               (when (zerop (hi::mark-charpos mark)) 
226                 (let ((def-info (definition-info (clone mark) objc-p)))
227                   (when def-info
228                     (push (cons def-info (hi::line-start (clone mark))) alist))))
229               (hi::line-end mark))))
230    (let* ((pane (slot-value hemlock 'gui::pane))
231           (text-view (gui::text-pane-text-view pane))
232           (buffer (gui::hemlock-buffer text-view))
233           (def-mark (clone (hi::buffer-start-mark buffer)))
234           (objc-mark (clone (hi::buffer-start-mark buffer)))
235           (def-alist (get-defs def-mark *def-search-pattern*))
236           (objc-alist (get-defs objc-mark *objc-defmethod-search-pattern* t)))
237      (when objc-alist
238        (setq def-alist
239              (if alpha-p
240                (merge 'list def-alist objc-alist #'string-lessp :key #'get-name)
241                (merge 'list def-alist objc-alist #'hi::mark< :key #'cdr))))
242      def-alist)))
243
244(defun definition-info (mark &optional objc-p)
245  "Returns (type name) or (type name signature specializer) for methods."
246  (flet ((substring-equal (string len)
247           (string-equal string 
248                         (hi::region-to-string 
249                          (hi::region mark (hi::character-offset (clone mark) len))))))
250    (let* ((def-type (cond (objc-p :objc)
251                           ((substring-equal "(defmethod" 10) :defmethod)
252                           ((substring-equal "(defun" 6) :defun)
253                           ((substring-equal "(defmacro" 9) :defmacro)
254                           ((substring-equal "(defclass" 9) :defclass)
255                           ((substring-equal "(defstruct" 10) :defstruct)
256                           (t :other)))
257           (end (let ((temp-mark (clone mark)))
258                  (when (hemlock::form-offset (hi::mark-after temp-mark) 2)
259                    temp-mark)))
260           (start (when end
261                    (let ((temp-mark (clone end)))
262                      (when (hemlock::form-offset temp-mark -1)
263                        temp-mark)))))
264      (when (and start end)
265        (let ((name (hi::region-to-string (hi::region start end)))
266              param-string specializer)
267          (when (and (stringp name) (string-not-equal name ""))
268            (case def-type
269              (:defmethod
270                  (let ((qualifier-start-mark (clone end))
271                        (left-paren-mark (clone end))
272                        right-paren-mark qualifier-end-mark qualifier-string)
273                    (when (hi::find-pattern left-paren-mark *left-paren-search-pattern*)
274                      (setq right-paren-mark (clone left-paren-mark))
275                      (when (hemlock::form-offset right-paren-mark 1)
276                        (multiple-value-setq (param-string specializer)
277                          (parse-parameters (clone left-paren-mark) right-paren-mark))))
278                    (when (hi::find-pattern qualifier-start-mark *colon-search-pattern* left-paren-mark)
279                      (setq qualifier-end-mark (clone qualifier-start-mark))
280                      (when (hemlock::form-offset qualifier-end-mark 1)
281                        (setq qualifier-string
282                              (hi::region-to-string (hi::region qualifier-start-mark qualifier-end-mark)))))
283                    (if qualifier-string
284                      ;; name is used to simplify the alpha sort:
285                      (list def-type name (format nil "(~A ~A ~A)" name qualifier-string param-string) specializer)
286                      (list def-type name (format nil "(~A ~A)" name param-string) specializer))))
287              (:objc
288               (let* ((name-start-mark (let ((temp-mark (clone start)))
289                                         (when (hi::find-pattern temp-mark *slash-search-pattern*)
290                                           (hi::mark-after temp-mark))))
291                      (name-end-mark (when name-start-mark
292                                       (let ((temp-mark (clone name-start-mark)))
293                                         (when (hemlock::form-offset temp-mark 1)
294                                           temp-mark))))
295                      (objc-name (when (and name-start-mark name-end-mark) 
296                                   (hi::region-to-string (hi::region name-start-mark name-end-mark))))
297                      (left-paren-mark (let ((temp-mark (clone end)))
298                                         (when (hi::find-pattern temp-mark *left-paren-search-pattern*)
299                                           temp-mark)))
300                      (right-paren-mark (when left-paren-mark 
301                                          (let ((temp-mark (clone left-paren-mark)))
302                                            (when (hi::form-offset temp-mark 1)
303                                              temp-mark)))))
304                 (when (and left-paren-mark right-paren-mark)
305                   (multiple-value-setq (param-string specializer)
306                     (parse-parameters left-paren-mark right-paren-mark t))
307                   ;; Using curly braces to distinguish objc methods from Lisp methods:
308                   (list def-type objc-name (format nil "{~A ~A}" objc-name param-string) specializer))))
309              (:defstruct
310                  (cond ((char= (hi::next-character start) #\()
311                         (let* ((space-position (position #\space name :test #'char=))
312                                (new-name (when space-position (subseq name 1 space-position))))
313                           (if new-name
314                             (list def-type new-name)
315                             (list def-type name))))
316                        (t
317                         (list def-type name))))
318              (t
319               (list def-type name)))))))))
320
321(defun parse-parameters (start-mark end-mark &optional objc-p)
322  "Construct the method's parameter string."
323  (let (specializers-processed-p specializer)
324    (flet ((get-param (start end)
325             (let ((next-character (hi::next-character start)))
326               (when (char= next-character #\&) (setq specializers-processed-p t))
327               (cond ((and (char= next-character #\() (not specializers-processed-p))
328                      (let* ((specializer-end (when (hemlock::form-offset (hi::mark-after start) 2) start))
329                             (specializer-start (when specializer-end (clone specializer-end))))
330                        (when (and specializer-end specializer-start
331                                   (hemlock::form-offset specializer-start -1)
332                                   (hi::mark< specializer-end end))
333                          (when objc-p (setq specializers-processed-p t))
334                          (hi::region-to-string (hi::region specializer-start specializer-end)))))
335                     (t 
336                      (unless (char= next-character #\&)
337                        (format nil "t")))))))
338      (do* ((sexp-end (let ((temp-mark (hi::mark-after (clone start-mark))))
339                        (when (hemlock::form-offset temp-mark 1) temp-mark))
340                      (when (hemlock::form-offset (hi::mark-after sexp-end) 1) sexp-end))
341            (sexp-start (when sexp-end
342                          (let ((temp-mark (clone sexp-end)))
343                            (when (hemlock::form-offset temp-mark -1) temp-mark)))
344                        (when sexp-end
345                          (let ((temp-mark (clone sexp-end)))
346                            (when (hemlock::form-offset temp-mark -1) temp-mark))))
347            (param-string (when (and sexp-start sexp-end) (get-param (clone sexp-start) 
348                                                                     (clone sexp-end)))
349                          (when (and sexp-start sexp-end) (get-param (clone sexp-start)
350                                                                     (clone sexp-end))))
351            (first-param-p t)
352            parameters)
353           ((or (null sexp-start) (null sexp-end) 
354                (hi::mark> sexp-start end-mark)
355                ;; Empty body case:
356                (hi::mark< sexp-start start-mark))
357            (values (concatenate 'string parameters ")") specializer))
358        (when param-string
359          (cond (first-param-p
360                 (setq parameters (concatenate 'string "(" param-string))
361                 (setq specializer param-string)
362                 (setq first-param-p nil))
363                (t
364                 (setq parameters (concatenate 'string parameters " " param-string)))))))))
365
366;;; This is used by the Hemlock-Commands tool. 
367(defun find-and-display-definition (name path)
368  "Display the file and scroll to the definition position."
369  (let ((window (window-with-path path))
370         mark def-list text-view hemlock-view)
371    (unless (probe-file path)
372      (notify (format nil "~a does not exist."
373                      path))
374      (return-from find-and-display-definition nil))
375    (cond (window 
376           (setq hemlock-view (gui::hemlock-view window))
377           (setq text-view (gui::text-pane-text-view (hi::hemlock-view-pane hemlock-view))))
378          (t
379           (setq hemlock-view (gui::cocoa-edit path))
380           (when hemlock-view
381             (setq window (#/window (hi::hemlock-view-pane hemlock-view)))
382             (setq text-view (gui::text-pane-text-view (hi::hemlock-view-pane hemlock-view))))))
383    (when window
384      (#/makeKeyAndOrderFront: window nil)
385      (setq def-list (list-definitions window))
386      (setq mark (cdr (assoc name def-list 
387                             :test #'string-equal
388                             :key #'(lambda (def-info)
389                                      (let ((def-type (first def-info)))
390                                        (if (or (eq def-type :defmethod)
391                                                (eq def-type :objc))
392                                          (third def-info)
393                                          (second def-info)))))))
394      (when mark (display-position text-view mark)))))
395
396
397(cmenu:register-tool "List-Definitions-CM" #'get-list-definitions-menu)
398
Note: See TracBrowser for help on using the repository browser.