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

Last change on this file since 12635 was 12635, checked in by gz, 10 years ago

move edit-definition from lispmode.lisp to edit-defs.lisp. Change it to use source locations when available: if there is no source text info, just go to the saved source position. If text is available, use it to attempt to find the definition even if something else in the file has changed. If can't find the definition using source location info, punt to the old code.

Make meta-. set mark before moving point to the definition, so can get back.

Make the warning message about using a different package show in the target buffer echo area, not the one left behind.

Replace hemlock-ext:edit-single-definition with a more general hemlock-ext:execute-in-file-view.

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