source: trunk/source/cocoa-ide/hemlock/src/edit-defs.lisp @ 15880

Last change on this file since 15880 was 15880, checked in by gz, 6 years ago

Make DEFINITIONS-IN-DOCUMENT also return the type of each definition

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 19.2 KB
Line 
1;;; -*- Log: hemlock.log; Package: hemlock -*-
2;;;
3;;; **********************************************************************
4;;; This code was written as part of the CMU Common Lisp project at
5;;; Carnegie Mellon University, and has been placed in the public domain.
6;;;
7#+CMU (ext:file-comment
8  "$Header$")
9;;;
10;;; **********************************************************************
11;;;
12;;; Editing DEFMACRO and DEFUN definitions.  Also, has directory translation
13;;; code for moved and/or different sources.
14;;;
15
16(in-package :hemlock)
17
18
19;;; Definition Editing Commands.
20
21
22
23;;; For the "Go to Definition" search pattern, we just use " " as the initial
24;;; pattern, so we can make a search pattern.  Invocation of the command alters
25;;; the search pattern.
26
27(defvar *go-to-def-pattern*
28  (new-search-pattern :string-insensitive :forward " "))
29
30(defvar *last-go-to-def-string* "")
31(declaim (simple-string *last-go-to-def-string*))
32 
33(defun symbol-at-point (buffer)
34  "Returns symbol at point, or contents of selection if there is one"
35  (let ((point (buffer-point buffer))
36        (mark (buffer-mark buffer)))
37    (if (and (hi::%buffer-current-region-p buffer)
38             (not (mark= mark point)))
39      (string-trim '(#\space #\tab)
40                   (region-to-string (if (mark< mark point)
41                                       (region mark point)
42                                       (region point mark))))
43      (symbol-at-mark buffer point))))
44
45(defun symbol-at-mark (buffer mark)
46  (with-mark ((mark1 mark)
47              (mark2 mark))
48    ;; This doesn't handle embedded #'s or escaped chars in names.
49    ;; So let them report it as a bug...
50    (when (test-char (previous-character mark) :lisp-syntax :constituent)
51      (or (rev-scan-char mark1 :lisp-syntax (not :constituent))
52          (buffer-start mark1))
53      (scan-char mark1 :lisp-syntax :constituent))
54    (when (test-char (next-character mark) :lisp-syntax :constituent)
55      (or (scan-char mark2 :lisp-syntax (not :constituent))
56          (buffer-end mark2)))
57    (when (mark= mark1 mark2)
58      ;; Try to get whole form
59      (pre-command-parse-check mark)
60      (move-mark mark1 mark)
61      (form-offset mark1 -1)
62      (move-mark mark2 mark1)
63      (form-offset mark2 1))
64    (loop until (or (mark= mark1 mark2) (not (eql (previous-character mark2) #\:)))
65      do (mark-before mark2))
66    (when (and (eql (previous-character mark1) #\#) (eql (next-character mark1) #\<))
67      (mark-after mark1))
68    (unless (mark= mark1 mark2)
69      (region-to-string (region mark1 mark2)))))
70
71(defcommand "Goto Definition" (p)
72  "Go to the current function/macro's definition.  With a numarg, prompts for name to go to."
73  (if p
74      (edit-definition-command nil)
75      (let* ((buffer (current-buffer))
76             (fun-name (symbol-at-point buffer)))
77        (if fun-name
78            (get-def-info-and-go-to-it fun-name (or
79                                                 (buffer-package buffer)
80                                                 *package*))
81            (beep)))))
82
83(defcommand "Edit Definition" (p)
84  "Prompts for function/macro's definition name and goes to it for editing."
85  (declare (ignore p))
86  (let ((fun-name (prompt-for-string
87                   :prompt "Name: "
88                   :help "Symbol name of function.")))
89    (get-def-info-and-go-to-it fun-name (or
90                                         (buffer-package (current-buffer))
91                                         *package*))))
92
93(defun get-def-info-and-go-to-it (string package)
94  (multiple-value-bind (fun-name error)
95      (let* ((*package* (ccl:require-type package 'package)))
96        (ignore-errors (values (read-from-string string))))
97    (if error
98      (editor-error "unreadable name: ~s" string)
99      (handler-case (edit-definition fun-name)
100        (error (c) (editor-error "~a" c))))))
101
102(defcommand "Edit Command Definition" (p)
103  "Prompts for command definition name and goes to it for editing."
104  (multiple-value-bind
105      (name command)
106      (if p
107        (multiple-value-bind (key cmd)
108                             (prompt-for-key :prompt "Edit command bound to: "
109                                             :must-exist t)
110          (declare (ignore key))
111          (values (command-name cmd) cmd))
112        (prompt-for-keyword :tables (list *command-names*)
113                            :prompt "Command to edit: "))
114    (declare (ignore name))
115    (handler-case (edit-definition (command-function command))
116      (error (c) (editor-error "~a" c)))))
117
118#|
119;;; FUN-DEFINED-FROM-PATHNAME takes a symbol or function object.  It
120;;; returns a pathname for the file the function was defined in.  If it was
121;;; not defined in some file, then nil is returned.
122;;;
123(defun fun-defined-from-pathname (function)
124  "Takes a symbol or function and returns the pathname for the file the
125   function was defined in.  If it was not defined in some file, nil is
126   returned."
127  (flet ((true-namestring (path) (namestring (truename path))))
128    (typecase function
129      (function (fun-defined-from-pathname (ccl:function-name function)))
130      (symbol (let* ((info (ccl::%source-files function)))
131                (if (atom info)
132                  (true-namestring info)
133                  (let* ((finfo (assq 'function info)))
134                    (when finfo
135                      (true-namestring
136                       (if (atom finfo)
137                         finfo
138                         (car finfo)))))))))))
139
140;;; GO-TO-DEFINITION tries to find name in file with a search pattern based
141;;; on type (defun or defmacro).  File may be translated to another source
142;;; file, and if type is a function that cannot be found, we try to find a
143;;; command by an appropriate name.
144;;;
145(defun go-to-definition (file type name)
146  (let ((pattern (get-definition-pattern type name)))
147    (cond
148     (file
149      (setf file (go-to-definition-file file))
150      (let* ((buffer (old-find-file-command nil file))
151             (point (buffer-point buffer))
152             (name-len (length name)))
153        (declare (fixnum name-len))
154        (with-mark ((def-mark point))
155          (buffer-start def-mark)
156          (unless (find-pattern def-mark pattern)
157            (if (and (or (eq type :function) (eq type :unknown-function))
158                     (> name-len 7)
159                     (string= name "COMMAND" :start1 (- name-len 7)))
160                (let ((prev-search-str *last-go-to-def-string*))
161                  (unless (find-pattern def-mark
162                                        (get-definition-pattern :command name))
163                    (editor-error "~A is not defined with ~S or ~S, ~
164                                   but this is the defined-in file."
165                                  (string-upcase name) prev-search-str
166                                  *last-go-to-def-string*)))
167                (editor-error "~A is not defined with ~S, ~
168                               but this is the defined-in file."
169                              (string-upcase name) *last-go-to-def-string*)))
170          (if (eq buffer (current-buffer))
171              (push-new-buffer-mark point))
172          (move-mark point def-mark))))
173     (t
174      (when (or (eq type :unknown-function) (eq type :unknown-macro))
175        (with-mark ((m (buffer-start-mark (current-buffer))))
176          (unless (find-pattern m pattern)
177            (editor-error
178             "~A is not compiled and not defined in current buffer with ~S"
179             (string-upcase name) *last-go-to-def-string*))
180          (let ((point (current-point)))
181            (push-new-buffer-mark point)
182            (move-mark point m))))))))
183|#
184
185(defparameter *type-defining-operators* ())
186
187(defun define-type-defining-operators (name &rest operators)
188  (assert (subtypep name 'ccl::definition-type))
189  (let ((a (assoc name *type-defining-operators*)))
190    (when (null a)
191      (push (setq a (cons name nil)) *type-defining-operators*))
192    (loop for op in operators do (pushnew op (cdr a)))
193    name))
194
195(defun type-defining-operator-p (def-type operator)
196  (loop for (type . ops) in *type-defining-operators*
197    thereis (and (typep def-type type) (memq operator ops))))
198
199(define-type-defining-operators 'ccl::class-definition-type 'defclass)
200(define-type-defining-operators 'ccl::type-definition-type 'deftype)
201(define-type-defining-operators 'ccl::function-definition-type 'defun 'defmacro 'defgeneric #+x8664-target 'ccl::defx86lapfunction #+ppc-target 'ccl::defppclapfunction)
202(define-type-defining-operators 'ccl::constant-definition-type 'defconstant)
203(define-type-defining-operators 'ccl::variable-definition-type 'defvar 'defparameter 'ccl::defstatic 'ccl::defglobal)
204(define-type-defining-operators 'ccl::method-combination-definition-type 'define-method-combination)
205(define-type-defining-operators 'ccl::compiler-macro-definition-type 'define-compiler-macro)
206
207
208(defun match-definition-context-for-method (end-mark package indicator)
209  (let* ((specializers (openmcl-mop:method-specializers indicator))
210         (qualifiers (openmcl-mop:method-qualifiers indicator)))
211    (block win
212      (with-mark ((work end-mark))
213        (when qualifiers
214          (dotimes (i (length qualifiers))
215            (unless (and (form-offset end-mark 1)
216                         (progn
217                           (move-mark work end-mark)
218                           (form-offset work -1)))
219              (return-from win nil))
220            (let* ((qualifier (ignore-errors
221                                (let* ((*package* package))
222                                  (values
223                                   (read-from-string (region-to-string
224                                                      (region
225                                                       work
226                                                       end-mark))))))))
227              (unless (member qualifier qualifiers)
228                (return-from win nil)))))
229        ;; end-mark is now either at end of last qualifier or
230        ;; after method name.  Try to read the lambda list and
231        ;; match specializers.
232        (unless (and (form-offset end-mark 1)
233                     (progn
234                       (move-mark work end-mark)
235                       (form-offset work -1)))
236          (return-from win nil))
237        (multiple-value-bind (lambda-list error)
238            (ignore-errors
239              (let* ((*package* package))
240                (values
241                 (read-from-string (region-to-string
242                                    (region
243                                     work
244                                     end-mark))))))
245          (unless (and (null error)
246                       (consp lambda-list)
247                       (ccl::proper-list-p lambda-list))
248            (return-from win nil))
249          (flet ((match-specializer (spec)
250                   (when lambda-list
251                     (let* ((arg (pop lambda-list)))
252                       (typecase spec
253                         (ccl::eql-specializer
254                          (let* ((obj (openmcl-mop:eql-specializer-object spec)))
255                            (and (ccl::proper-list-p arg)
256                                 (= 2 (length arg))
257                                 (symbolp (pop arg))
258                                 (ccl::proper-list-p (setq arg (car arg)))
259                                 (= (length arg) 2)
260                                 (eq (car arg) 'eql)
261                                 (eql (cadr arg) obj))))
262                         (class
263                          (let* ((name (class-name spec)))
264                            (or (and (eq name t) (symbolp arg))
265                                (and (consp arg)
266                                     (symbolp (car arg))
267                                     (consp (cdr arg))
268                                     (null (cddr arg))
269                                     (eq name (cadr arg)))))))))))
270            (dolist (spec specializers t)
271              (unless (match-specializer spec)
272                (return nil)))))))))
273                                 
274;;; START and END delimit a function name that matches what we're looking for
275(defun match-context-for-indicator (start end def-type full-name)
276  (with-mark ((op-start start)
277              (op-end start))
278    (and (form-offset op-start -1)
279         (progn
280           (move-mark op-end op-start)
281           (form-offset op-end 1))
282         (let* ((package (or (find-package (variable-value 'current-package :buffer (current-buffer)))
283                             *package*))
284                (defining-operator
285                    (ignore-errors
286                      (let* ((*package* package))
287                        (values (read-from-string (region-to-string (region op-start op-end))))))))
288           (and (type-defining-operator-p def-type defining-operator)
289                (or (not (typep full-name 'method))
290                    (match-definition-context-for-method end package full-name)))))))
291
292(defun match-definition-context (mark def-type full-name)
293  (pre-command-parse-check mark)
294  (when (valid-spot mark t)
295    (with-mark ((start mark)
296                (end mark))
297      (and (form-offset end 1)
298           (progn
299             (move-mark start end)
300             (form-offset start -1))
301           (let ((package (or (find-package (variable-value 'current-package :buffer (current-buffer)))
302                              *package*)))
303             (eq (ccl::definition-base-name def-type full-name)
304                 (ignore-errors
305                  (let* ((*package* package))
306                    (values (read-from-string (region-to-string (region start end))))))))
307           (match-context-for-indicator start end def-type full-name)))))
308
309(defun find-definition-by-context (def-type full-name)
310  (let* ((base-name (ccl::definition-base-name def-type full-name))
311         (string (string base-name))
312         (pattern (new-search-pattern :string-insensitive :forward string))
313         (found 0))
314    (with-mark ((mark (buffer-start-mark (current-buffer))))
315      (when (or (loop
316                  while (and (find-pattern mark pattern) (incf found))
317                  thereis (and (match-definition-context mark def-type full-name)
318                               (backward-up-list mark))
319                  do (character-offset mark 1))
320                ;; if there is only one instance, just go there
321                (and (eql found 1) (find-pattern (buffer-start mark) pattern))
322                ;; Else should try again, being less strict...
323                )
324        (move-point-leaving-mark mark)))))
325
326(defun move-point-leaving-mark (target)
327  (let ((point (current-point-collapsing-selection)))
328    (push-new-buffer-mark point)
329    (move-mark point target)
330    point))
331
332;;; Adjust for CRLF line termination.  Multibyte character encodings
333;;; can also cause discrepancies between physical/logical positions.
334;;; Handling that would require making the source location stuff
335;;; aware of that newfangled Unicode thing ...
336(defun byte-position-to-character-position (pos &optional (buffer (current-buffer)))
337  (let* ((line-termination (hi::buffer-line-termination buffer)))
338    (if (eq line-termination :crlf)
339      (- pos (hi::buffer-lines-before-absolute-position buffer pos))
340      pos)))
341
342(defun move-to-source-note (source)
343  (let ((start-pos (ccl:source-note-start-pos source)))
344    (when start-pos
345      (setq start-pos (byte-position-to-character-position start-pos))
346      (let ((full-text (ccl:source-note-text source))
347            (pattern nil)
348            (offset 0))
349        (flet ((ssearch (mark string direction)
350                 (find-pattern mark
351                               (setq pattern (new-search-pattern :string-insensitive
352                                                                 direction
353                                                                 string
354                                                                 pattern)))))
355          (declare (inline ssearch))
356          (with-mark ((temp-mark (current-point)))
357            (unless full-text
358              ;; Someday, might only store a snippet for toplevel, so inner notes
359              ;; might not have text, but can still find them through the toplevel.
360              (let* ((toplevel (ccl::source-note-toplevel-note source))
361                     (toplevel-start-pos (and (not (eq toplevel source))
362                                              (ccl:source-note-start-pos toplevel)))
363                     (text (and toplevel-start-pos (ccl:source-note-text toplevel))))
364                (when text
365                  (setq toplevel-start-pos (byte-position-to-character-position toplevel-start-pos))
366                  (setq offset (- start-pos toplevel-start-pos))
367                  (setq start-pos toplevel-start-pos)
368                  (setq full-text text)
369                  (character-offset temp-mark (- offset)))))
370            (unless (move-to-absolute-position temp-mark start-pos)
371              (buffer-end temp-mark))
372
373            (when (or (null full-text)
374                      (or (ssearch temp-mark full-text :forward)
375                          (ssearch temp-mark full-text :backward))
376                      ;; Maybe body changed, try at least to match the start of it
377                      (let ((snippet (and (> (length full-text) 60) (subseq full-text 0 60))))
378                        (and snippet
379                             (or (ssearch temp-mark snippet :forward)
380                                 (ssearch temp-mark snippet :backward)))))
381              (let ((point (move-point-leaving-mark temp-mark)))
382                (or (character-offset point offset)
383                    (buffer-end point))))))))))
384
385(defun find-definition-in-buffer (def-type full-name source)
386  (or (and (ccl:source-note-p source)
387           (move-to-source-note source))
388      (find-definition-by-context def-type full-name)
389      (editor-error "Couldn't find definition for ~s" full-name)))
390
391;; Note this isn't necessarily called from hemlock, e.g. it might be called by cl:ed,
392;; from any thread, or it might be called from a sequence dialog, etc.
393(defun edit-definition (name)
394  (flet ((get-source-alist (name)
395           (let ((list (ccl:find-definition-sources name t)))
396             ;; filter interactive-only defs
397             (loop for (id . sources) in list as source = (find-if-not #'null sources)
398               when source collect (cons id source))))
399         (defn-name (defn stream)
400           (destructuring-bind (dt . full-name) (car defn)
401             (format stream "~s ~s" (ccl:definition-type-name dt) (ccl:name-of full-name))))
402         (defn-action (defn &optional msg)
403           (destructuring-bind ((def-type . full-name) . source) defn
404             (hemlock-ext:execute-in-file-view
405              (ccl:source-note-filename source)
406              (lambda ()
407                (when msg (loud-message msg))
408                (find-definition-in-buffer def-type full-name source))))))
409    (let* ((info (get-source-alist name))
410           (msg nil))
411      (when (and (null info) (symbolp name))
412        (let* ((seen (list name))
413               (found ())
414               (pname (symbol-name name)))
415          (dolist (pkg (list-all-packages))
416            (let ((sym (find-symbol pname pkg)))
417              (when (and sym (not (member sym seen :test 'eq)))
418                (let ((new (get-source-alist sym)))
419                  (when new
420                    (setq info (nconc new info))
421                    (push sym found)))
422                (push sym seen))))
423          (when found
424            (setq msg (format nil "No definitions for ~s, found ~s instead"
425                              name (if (cdr found) found (car found)))))))
426      (if info
427        (if (cdr info)
428          (progn
429            (when msg (loud-message msg))
430            (hemlock-ext:open-sequence-dialog
431             :title (format nil "Definitions of ~s" name)
432             :sequence info
433             :action #'defn-action
434             :printer #'defn-name))
435          (defn-action (car info) msg))
436        (editor-error "No known definitions for ~s" name)))))
437
Note: See TracBrowser for help on using the repository browser.