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

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

Added parse-over-block to list-definitions, duh.

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