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

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

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

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