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