Changeset 12635


Ignore:
Timestamp:
Aug 20, 2009, 2:59:37 AM (10 years ago)
Author:
gz
Message:

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.

Location:
trunk/source/cocoa-ide
Files:
5 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/cocoa-ide/cocoa-editor.lisp

    r12628 r12635  
    32313231      (front-view-for-buffer (hemlock-buffer doc)))))
    32323232
    3233 (defun cocoa-edit-single-definition (name info)
    3234   (assume-cocoa-thread)
    3235   (destructuring-bind (indicator . pathname) info
    3236     (let ((view (find-or-make-hemlock-view pathname)))
    3237       (hi::handle-hemlock-event view
    3238                                 #'(lambda ()
    3239                                     (hemlock::find-definition-in-buffer name indicator))))))
    3240 
    3241 (defun hemlock-ext:edit-single-definition (name info)
    3242   (execute-in-gui #'(lambda () (cocoa-edit-single-definition name info))))
     3233(defun hemlock-ext:execute-in-file-view (pathname thunk)
     3234  (execute-in-gui #'(lambda ()
     3235                      (assume-cocoa-thread)
     3236                      (let ((view (find-or-make-hemlock-view pathname)))
     3237                        (hi::handle-hemlock-event view thunk)))))
     3238
    32433239
    32443240(defun hemlock-ext:open-sequence-dialog (&key title sequence action (printer #'prin1))
  • trunk/source/cocoa-ide/hemlock/src/edit-defs.lisp

    r12235 r12635  
    6363(defcommand "Goto Definition" (p)
    6464  "Go to the current function/macro's definition.  With a numarg, prompts for name to go to."
    65   "Go to the current function/macro's definition."
    6665  (if p
    6766      (edit-definition-command nil)
     
    187186|#
    188187
    189 (defparameter *source-file-indicator-defining-operators* ())
    190 
    191 (defun define-source-file-indicator-defining-operators (name &rest operators)
    192   (setf (getf *source-file-indicator-defining-operators* name) operators))
    193 
    194 (defun get-source-file-indicator-defining-operators (thing)
    195   (if (typep thing 'method)
    196     '(defmethod)
    197     (getf *source-file-indicator-defining-operators* thing)))
    198 
    199 (define-source-file-indicator-defining-operators 'class 'defclass)
    200 (define-source-file-indicator-defining-operators 'type 'deftype)
    201 (define-source-file-indicator-defining-operators 'function 'defun 'defmacro 'defgeneric #+x8664-target 'ccl::defx86lapfunction #+ppc-target 'ccl::defppclapfunction)
    202 (define-source-file-indicator-defining-operators 'ccl::constant 'defconstant)
    203 (define-source-file-indicator-defining-operators 'variable 'defvar 'defparameter 'ccl::defstatic 'ccl::defglobal)
    204 (define-source-file-indicator-defining-operators 'method-combination 'define-method-combination)
    205 (define-source-file-indicator-defining-operators 'ccl::method-combination-evaluator 'ccl::define-method-combination-evaluator)
    206 (define-source-file-indicator-defining-operators 'compiler-macro 'define-compiler-macro)
    207 #+ppc32-target
    208 (define-source-file-indicator-defining-operators 'ccl::ppc32-vinsn 'ccl::define-ppc32-vinsn)
    209 #+ppc64-target
    210 (define-source-file-indicator-defining-operators 'ccl::ppc64-vinsn 'ccl::define-ppc64-vinsn)
    211 #+x8664-target
    212 (define-source-file-indicator-defining-operators 'ccl::x8664-vinsn 'ccl::define-x8664-vinsn)
     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)
    213209
    214210
     
    279275                (return nil)))))))))
    280276                                 
    281                        
    282        
    283 ;;; START and END delimit a function name that matches what we're looking
    284 ;;; for, PACKAGE is the buffer's package (or *PACKAGE*), and INDICATOR
    285 ;;; is either a symbol (FUNCTION, MACRO, etc) or a METHOD object.
    286 (defun match-context-for-indicator (start end package indicator)
    287   (declare (ignorable end))
     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)
    288279  (with-mark ((op-start start)
    289280              (op-end start))
     
    292283           (move-mark op-end op-start)
    293284           (form-offset op-end 1))
    294          (let* ((defining-operator
     285         (let* ((package (or (find-package (variable-value 'current-package :buffer (current-buffer)))
     286                             *package*))
     287                (defining-operator
    295288                    (ignore-errors
    296289                      (let* ((*package* package))
    297290                        (values (read-from-string (region-to-string (region op-start op-end))))))))
    298            (memq
    299             defining-operator
    300             (get-source-file-indicator-defining-operators indicator)))
    301          (or (not (typep indicator 'method))
    302              (match-definition-context-for-method end package indicator)))))
    303 
    304 
    305 (defun match-definition-context (mark name indicator package)
     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)
    306296  (pre-command-parse-check mark)
    307297  (when (valid-spot mark t)
     
    312302             (move-mark start end)
    313303             (form-offset start -1))
    314            (eq name (ignore-errors
    315                       (let* ((*package* package))
    316                         (values (read-from-string (region-to-string (region start end)))))))
    317            (match-context-for-indicator start end package indicator)))))
    318 
    319 (defun find-definition-in-buffer (name indicator)
    320   (let ((buffer (current-buffer)))
    321     (setf (hi::buffer-region-active buffer) nil)
    322     (when (symbolp name)
    323       (let* ((string (string name))
    324              (len (length string))
    325              (pattern (get-search-pattern string :forward))
    326              (mark (copy-mark (buffer-start-mark buffer)))
    327              (package (or
    328                        (find-package
    329                         (variable-value 'current-package :buffer buffer))
    330                        *package*)))
    331         (or
    332          (loop
    333            (let* ((won (find-pattern mark pattern)))
    334              (unless won
    335                (return))
    336              (when (match-definition-context mark name indicator package)
    337                (backward-up-list mark)
    338                (move-mark (buffer-point buffer) mark)
    339                (return t))
    340              (unless (character-offset mark len)
    341                (return))))
    342          (editor-error "Couldn't find definition for ~s" name))))))
     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
  • trunk/source/cocoa-ide/hemlock/src/lispmode.lisp

    r12599 r12635  
    19851985         :action #'edit-definition)))))
    19861986
    1987 ;; Note this isn't necessarily called from hemlock, e.g. it might be called by cl:ed,
    1988 ;; from any thread, or it might be called from a sequence dialog, etc.
    1989 (defun edit-definition (name)
    1990   (flet ((get-source-alist (name)
    1991            (mapcar #'(lambda (item) (cons name item))
    1992                    (ccl::get-source-files-with-types&classes name))))
    1993     (let* ((info (get-source-alist name)))
    1994       (when (null info)
    1995         (let* ((seen (list name))
    1996                (found ())
    1997                (pname (symbol-name name)))
    1998           (dolist (pkg (list-all-packages))
    1999             (let ((sym (find-symbol pname pkg)))
    2000               (when (and sym (not (member sym seen)))
    2001                 (let ((new (get-source-alist sym)))
    2002                   (when new
    2003                     (setq info (nconc new info))
    2004                     (push sym found)))
    2005                 (push sym seen))))
    2006           (when found
    2007             ;; Unfortunately, this puts the message in the wrong buffer (would be better in the destination buffer).
    2008             (loud-message "No definitions for ~s, using ~s instead"
    2009                           name (if (cdr found) found (car found))))))
    2010       (if info
    2011         (if (cdr info)
    2012           (hemlock-ext:open-sequence-dialog
    2013            :title (format nil "Definitions of ~s" name)
    2014            :sequence info
    2015            :action #'(lambda (item) (hemlock-ext:edit-single-definition (car item) (cdr item)))
    2016            :printer #'(lambda (item stream) (prin1 (cadr item) stream)))
    2017           (hemlock-ext:edit-single-definition (caar info) (cdar info)))
    2018         (editor-error "No known definitions for ~s" name)))))
    2019 
    20201987#||
    20211988(defcommand "Set Package Name" (p)
  • trunk/source/cocoa-ide/hemlock/src/package.lisp

    r12538 r12635  
    374374   #:all-hemlock-views
    375375   #:open-sequence-dialog
    376    #:edit-single-definition
     376   #:execute-in-file-view
    377377   #:change-active-pane
    378378   #:send-string-to-listener
  • trunk/source/cocoa-ide/hemlock/src/search1.lisp

    r12170 r12635  
    6363;;;
    6464(defmacro define-search-kind (kind lambda-list documentation &body forms)
    65   (let ((dummy #-CLISP (gensym) #+CLISP (gentemp (format nil ".search-kind.~A" kind))))
    66     `(progn
    67       (push ,documentation *search-pattern-documentation*)
    68       (defun ,dummy ()
    69         (setf (gethash ,kind *search-pattern-experts*)
    70               #'(lambda ,lambda-list ,@forms)))
    71       (,dummy))))
     65  `(progn
     66     (push ,documentation *search-pattern-documentation*)
     67     (setf (gethash ,kind *search-pattern-experts*)
     68           #'(lambda ,lambda-list ,@forms))))
    7269
    7370
     
    646643  is returned.
    647644  If stop-mark is specified, NIL is returned and mark is not moved if
    648   the point before the match is after stop-mark"
     645  the point before the match is after stop-mark for forward search or
     646  before stop-mark for backward search"
    649647  (close-line)
    650648  (multiple-value-bind (line start matched)
     
    654652    (when (and matched
    655653               (or (null stop-mark)
    656                    (< (line-number line) (line-number (mark-line stop-mark)))
    657                    (and (= (line-number line) (line-number (mark-line stop-mark)))
    658                         (<= start (mark-charpos stop-mark)))))
     654                   (if (eq (search-pattern-direction search-pattern) :forward)
     655                     (or (< (line-number line) (line-number (mark-line stop-mark)))
     656                         (and (eq line (mark-line stop-mark))
     657                              (<= start (mark-charpos stop-mark))))
     658                     (or (< (line-number (mark-line stop-mark)) (line-number line))
     659                         (and (eq (mark-line stop-mark) line)
     660                              (<= (mark-charpos stop-mark) start))))))
    659661      (move-to-position mark start line)
    660662      matched)))
Note: See TracChangeset for help on using the changeset viewer.