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

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

Renamed load-list-definitions.lisp, list-definitions.lisp, so that (require :list-definitions) will work

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