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