source: trunk/source/contrib/Glen Foy/list-definitions.lisp @ 12568

Last change on this file since 12568 was 12568, checked in by rme, 11 years ago

Contributions from Glen Foy and Neil Baylis.

  • Property svn:executable set to *
File size: 12.2 KB
Line 
1;;;-*-Mode: LISP; Package: LIST-DEFINITIONS -*-
2
3;;; ----------------------------------------------------------------------------
4;;;
5;;;      list-definitions.lisp, version 0.1b1
6;;;
7;;;      copyright © 2009 Glen Foy
8;;;      (Permission is granted to Clozure, Inc. to distribute this file.)
9;;;
10;;;      This code adds a dynamic contextual popup menu to Hemlock.
11;;;
12;;;      Control-Click produces an alphabetized listing of the file's definitions. 
13;;;      Control-Command-Click produces a positional listing.
14;;;
15;;;      If you have a two button mouse, you would just use Right-Click and
16;;;      Command-Right-Click, respectively.  (Option-Right-Click produces
17;;;      the standard contextual menu.)
18;;;
19;;;      The most recent version will be available at: www.clairvaux.org
20;;;
21;;;      This software is offered "as is", without warranty of any kind.
22;;;
23;;; ----------------------------------------------------------------------------
24
25(defpackage "LIST-DEFINITIONS" (:nicknames "LDefs") (:use :cl :ccl))
26(in-package "LIST-DEFINITIONS")
27
28(defParameter *objc-defmethod-search-pattern* (hi::new-search-pattern :string-insensitive :forward "(objc:defmethod"))
29(defParameter *def-search-pattern* (hi::new-search-pattern :string-insensitive :forward "(def"))
30(defParameter *left-paren-search-pattern* (hi::new-search-pattern :character :forward #\())
31(defParameter *colon-search-pattern* (hi::new-search-pattern :character :forward #\:))
32(defParameter *slash-search-pattern* (hi::new-search-pattern :character :forward #\/))
33
34(defmacro clone (mark) `(hi::copy-mark ,mark :temporary))
35
36(defun active-hemlock-window ()
37  (gui::first-window-satisfying-predicate 
38   #'(lambda (w)
39       (and (typep w 'gui::hemlock-frame)
40            (not (typep w 'gui::hemlock-listener-frame))
41            (#/isKeyWindow w)))))
42
43;;; ----------------------------------------------------------------------------
44;;;
45(defclass list-definitions-menu (ns:ns-menu)
46  ((menu-text-view :initarg :menu-text-view :reader menu-text-view))
47  (:metaclass ns:+ns-object))
48
49(objc:defmethod (#/listDefinitionsAction: :void) ((m list-definitions-menu) (sender :id))
50  (let* ((def-pos (hi::mark-absolute-position (definition-mark sender)))
51         (def-end-pos (let ((temp-mark (clone (definition-mark sender))))
52                        (when (hemlock::form-offset temp-mark 1)
53                          (hi::mark-absolute-position temp-mark)))))
54    (when (and def-pos def-end-pos)
55      (ns:with-ns-range (range def-pos (- def-end-pos def-pos))
56        (#/scrollRangeToVisible: (menu-text-view m) range))
57      (hi::move-mark (hi::buffer-point (gui::hemlock-buffer (menu-text-view m))) (definition-mark sender))
58      (gui::update-paren-highlight (menu-text-view m)))))
59
60;;; ----------------------------------------------------------------------------
61;;;
62(defclass list-definitions-menu-item (ns:ns-menu-item)
63  ((definition-mark :accessor definition-mark))
64  (:metaclass ns:+ns-object))
65
66;;; This is not retained -- assumming autorelease.
67(defun list-definitions-context-menu (view &optional alpha-p)
68  (let* ((menu (make-instance 'list-definitions-menu :menu-text-view view))
69         (window (active-hemlock-window))
70         (alist (when window (list-definitions window alpha-p)))
71         menu-item)
72    (dolist (entry alist)
73      (setq menu-item (#/initWithTitle:action:keyEquivalent: 
74                       (#/alloc list-definitions-menu-item)
75                       (ccl::%make-nsstring (if (listp (car entry))
76                                              (second (car entry))
77                                              (car entry)))
78                       (ccl::@selector "listDefinitionsAction:")
79                       #@""))
80      (setf (definition-mark menu-item) (cdr entry))
81      (#/setTarget: menu-item  menu)
82      (#/addItem: menu menu-item))
83    menu))
84
85(objc:defmethod #/menuForEvent: ((view gui::hemlock-text-view) (event :id))
86  (if (logtest #$NSAlternateKeyMask (#/modifierFlags event))
87    (gui::text-view-context-menu)
88    (if (logtest #$NSCommandKeyMask (#/modifierFlags event))
89      (list-definitions-context-menu view nil)
90      (list-definitions-context-menu view t))))
91
92;;; This includes definitions in sharp-stroke comments.  We'll claim it's a feature.
93(defun list-definitions (hemlock &optional alpha-p)
94  (labels ((compare-names (name-1 name-2) (string-lessp name-1 name-2))
95           (get-name (entry)
96             (let ((name (car entry)))
97               (if (listp name) (first name) name)))
98           (get-defs (mark pattern &optional objc-p)
99             (do ((def-found-p (hi::find-pattern mark pattern)
100                               (hi::find-pattern mark pattern))
101                  alist)
102                 ((not def-found-p) (when alist
103                                      (if alpha-p 
104                                        (sort alist #'compare-names :key #'get-name) 
105                                        (nreverse alist))))
106               (when (zerop (hi::mark-charpos mark)) 
107                 (let ((definition-signature (definition-signature (clone mark) objc-p)))
108                   (when definition-signature
109                     (push (cons definition-signature (hi::line-start (clone mark))) alist))))
110               (hi::line-end mark))))
111    (let* ((pane (slot-value hemlock 'gui::pane))
112           (text-view (gui::text-pane-text-view pane))
113           (buffer (gui::hemlock-buffer text-view))
114           (def-mark (clone (hi::buffer-start-mark buffer)))
115           (objc-mark (clone (hi::buffer-start-mark buffer)))
116           (def-alist (get-defs def-mark *def-search-pattern*))
117           (objc-alist (get-defs objc-mark *objc-defmethod-search-pattern* t)))
118      (when objc-alist
119        (setq def-alist
120              (if alpha-p
121                (merge 'list def-alist objc-alist #'compare-names :key #'get-name)
122                (merge 'list def-alist objc-alist #'hi::mark< :key #'cdr))))
123      def-alist)))
124
125(defun definition-signature (mark &optional objc-p)
126  (let* ((method-p (unless objc-p
127                     (string-equal "(defmethod" 
128                                   (hi::region-to-string 
129                                    (hi::region mark (hi::character-offset (clone mark) 10))))))
130         (end (let ((temp-mark (clone mark)))
131                (when (hemlock::form-offset (hi::mark-after temp-mark) 2)
132                  temp-mark)))
133         (start (when end
134                  (let ((temp-mark (clone end)))
135                    (when (hemlock::form-offset temp-mark -1)
136                      temp-mark)))))
137    (when (and start end)
138      (let ((name (hi::region-to-string (hi::region start end))))
139        (cond (method-p
140               (let ((qualifier-start-mark (clone end))
141                     (left-paren-mark (clone end))
142                     right-paren-mark qualifier-end-mark param-string qualifier-string)
143                 (when (hi::find-pattern left-paren-mark *left-paren-search-pattern*)
144                   (setq right-paren-mark (clone left-paren-mark))
145                   (when (hemlock::form-offset right-paren-mark 1)
146                     (setq param-string (parse-parameters (clone left-paren-mark) right-paren-mark))))
147                 (when (hi::find-pattern qualifier-start-mark *colon-search-pattern* left-paren-mark)
148                   (setq qualifier-end-mark (clone qualifier-start-mark))
149                   (when (hemlock::form-offset qualifier-end-mark 1)
150                     (setq qualifier-string
151                           (hi::region-to-string (hi::region qualifier-start-mark qualifier-end-mark)))))
152                 (if qualifier-string
153                   ;; Returning a list, with name in the car, to simplify alpha sort:
154                   (list name (format nil "(~A ~A ~A)" name qualifier-string param-string))
155                   (list name (format nil "(~A ~A)" name param-string)))))
156              (objc-p
157               (let* ((name-start-mark (let ((temp-mark (clone start)))
158                                         (when (hi::find-pattern temp-mark *slash-search-pattern*)
159                                           (hi::mark-after temp-mark))))
160                      (name-end-mark (when name-start-mark
161                                       (let ((temp-mark (clone name-start-mark)))
162                                         (when (hemlock::form-offset temp-mark 1)
163                                           temp-mark))))
164                      (objc-name (when (and name-start-mark name-end-mark) 
165                                   (hi::region-to-string (hi::region name-start-mark name-end-mark))))
166                      (left-paren-mark (let ((temp-mark (clone end)))
167                                          (when (hi::find-pattern temp-mark *left-paren-search-pattern*)
168                                            temp-mark)))
169                      (right-paren-mark (when left-paren-mark 
170                                          (let ((temp-mark (clone left-paren-mark)))
171                                            (when (hi::form-offset temp-mark 1)
172                                              temp-mark))))
173                      param-string)
174                 (when (and left-paren-mark right-paren-mark)
175                   (setq param-string (parse-parameters left-paren-mark right-paren-mark t))
176                   ;; Using curly braces to distinguish objc methods from Lisp methods:
177                   (list objc-name (format nil "{~A ~A}" objc-name param-string)))))
178              (t
179               name))))))
180
181(defun parse-parameters (start-mark end-mark &optional objc-p)
182  (let (specializers-processed-p)
183    (flet ((get-param (start end)
184             (let ((next-character (hi::next-character start)))
185               (when (char= next-character #\&) (setq specializers-processed-p t))
186               (cond ((and (char= next-character #\() (not specializers-processed-p))
187                      (let* ((specializer-end (when (hemlock::form-offset (hi::mark-after start) 2) start))
188                             (specializer-start (when specializer-end (clone specializer-end))))
189                        (when (and specializer-end specializer-start
190                                   (hemlock::form-offset specializer-start -1)
191                                   (hi::mark< specializer-end end))
192                          (when objc-p (setq specializers-processed-p t))
193                          (hi::region-to-string (hi::region specializer-start specializer-end)))))
194                     (t 
195                      (unless (char= next-character #\&)
196                        (format nil "t")))))))
197      (do* ((sexp-end (let ((temp-mark (hi::mark-after (clone start-mark))))
198                        (when (hemlock::form-offset temp-mark 1) temp-mark))
199                      (when (hemlock::form-offset (hi::mark-after sexp-end) 1) sexp-end))
200            (sexp-start (when sexp-end
201                          (let ((temp-mark (clone sexp-end)))
202                            (when (hemlock::form-offset temp-mark -1) temp-mark)))
203                        (when sexp-end
204                          (let ((temp-mark (clone sexp-end)))
205                            (when (hemlock::form-offset temp-mark -1) temp-mark))))
206            (param-string (when (and sexp-start sexp-end) (get-param (clone sexp-start) 
207                                                                     (clone sexp-end)))
208                          (when (and sexp-start sexp-end) (get-param (clone sexp-start)
209                                                                     (clone sexp-end))))
210            (first-param-p t)
211            parameters)
212           ((or (null sexp-start) (null sexp-end) 
213                (hi::mark> sexp-start end-mark)
214                ;; Empty body case:
215                (hi::mark< sexp-start start-mark))
216            (concatenate 'string parameters ")"))
217        (when param-string
218          (cond (first-param-p
219                 (setq parameters (concatenate 'string "(" param-string))
220                 (setq first-param-p nil))
221                (t
222                 (setq parameters (concatenate 'string parameters " " param-string)))))))))
223 
224#|
225(defun test-list-definitions ()
226  (let* ((window (active-hemlock-window))
227         (alist (when window (list-definitions window))))
228    (dolist (entry alist)
229      (format t "~%~%~S" (car entry))
230      (format t "~%~S" (cdr entry)))))
231
232(gui::execute-in-gui  'test-list-definitions)
233|# 
234     
235
236
237
238
239
240
241
242
Note: See TracBrowser for help on using the repository browser.