emacs-devel
[Top][All Lists]
Advanced

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

Re: Is there a "selective setq locator/highlighter" anywhere? There is n


From: Alan Mackenzie
Subject: Re: Is there a "selective setq locator/highlighter" anywhere? There is now!
Date: Fri, 23 Jan 2009 15:58:57 +0000
User-agent: Mutt/1.5.9i

Hi, Davis!

On Thu, Jan 22, 2009 at 10:06:28AM -0800, Davis Herring wrote:
> > I would like a tool which would highlight these:

> >     (setq foo bar
> >           c-state-cache (cdr c-state-cache))
> >     (setcar c-state-cache (caar c-state-cache))

> > , but not this:

> >     (setq old-cache c-state-cache)

> Not a polished tool, by any means, but can't you just do

[ .... ]

> Wrap in defuns/commands as desired.

Thanks!  In the end, I just threw it together, and it rapidly converged
to something functional.  It handles setq, setc[ad]r and let\*?,
arbitrarily nested.  For some reason, I was thinking of a solution which
would first read (as in read/eval/print loop) a defun and then step
through the structure.  This was silly.  ;-)  Anyhow, here it is for
anybody interested.  It uses hi-lock-mode a little bit:

#########################################################################
;; Selective setq highlighting:
;;
;; Given a symbol, locate and/or highlight all places where the symbol's value
;; is changed; currently this means "(setq foo" (including multiple versions
;; of it), "(setcar foo" or "(setcdr foo", or "(let (...(foo ..)" or
;; "(let*...".

(defun sshi-forward-WS ()
  (save-match-data
    (forward-comment 1048575)
    (search-forward-regexp "[[:space:]]*")))

(defun sshi-sym-value ()
  "Parse the symbol followed by a sexp at point.
Return the positions of the symbol/sexp as a dotted pair of
dotted pairs like this
    ((SYM-START . SYM-END) . (SEXP-START . SEXP-END)).
Point is left after any WS/comments at sexp-end.
On error, throw an error."
  (let (sym-pos sexp-start)
    (if (looking-at "\\(\\(\\w\\|\\s_\\)+\\_>\\)") ; a symbol.
        ;;             1  2            2       1
        (progn
          (setq sym-pos (cons (match-beginning 1) (match-end 1)))
          (goto-char (match-end 0))
          (sshi-forward-WS)
          (setq sexp-start (point))
          (condition-case nil
              (forward-sexp)
            (error
             (error "sshi-sym-value: invalid sexp at %s" (point)))))
      (error "sshi-sym-value: missing symbol at %s" (point)))
    (prog1 (cons sym-pos (cons sexp-start (point)))
      (sshi-forward-WS))))

(defun sshi-push-sym-sexps (sym places)
  "  Push the locations of SYM settings onto PLACES, returning PLACES.
This includes any setq's etc. recursively contained in the sexp.
Point should be at a symbol in a \"setq\" type construct.  Point
is left after WS/comments after the sexp."
  (let ((sym-val (sshi-sym-value)))
    (if (string=
         (buffer-substring-no-properties (caar sym-val) (cdar sym-val))
         sym)
        (push (car sym-val) places))
    (when (eq (char-after (cadr sym-val)) ?\()
      (goto-char (cadr sym-val))
      (setq places
            (append (save-restriction
                      (narrow-to-region (cadr sym-val) (cddr sym-val))
                      (sshi-list sym))
                    places))
      (sshi-forward-WS))
    places))

(defun sshi-list (sym)
  "Return a list of places within the current restriction where SYM is set.
This is a list of dotted pairs of the form (BEGIN-SYM . END-SYM).

The current restriction should exactly contain a list, and point
should be at (point-min) on entry.  Point is left at (point-max)
at exit."
  (let (places sym-start)
    (forward-char)                      ; over ?\(
    (sshi-forward-WS)
    (while (/= (char-after) ?\))
      (cond
       ((looking-at "(\\(setc[ad]r\\_>\\)")
        (goto-char (match-end 0)) (sshi-forward-WS)
        (setq places (sshi-push-sym-sexps sym places))
        (sshi-forward-WS)
        (forward-char)                  ; over ?\)
        (sshi-forward-WS))

       ((looking-at "(\\(setq\\_>\\)")
        (goto-char (match-end 0)) (sshi-forward-WS)
        (while (/= (char-after) ?\))
          (setq places (sshi-push-sym-sexps sym places))
          (sshi-forward-WS))
        (forward-char) (sshi-forward-WS)) ; over ?\)

       ((looking-at "(\\(let\\*?\\_>\\)")
        (goto-char (match-end 0)) (sshi-forward-WS)
        (or (eq (char-after) ?\()
            (error "sshi: missing bindings list at %s" (point)))
        (forward-char) (sshi-forward-WS) ; over ?\(
        (while (/= (char-after) ?\))
          (if (eq (char-after) ?\()     ; binding with initialisation
              (progn
                (forward-char) (sshi-forward-WS) ; over ?\( of a single binding.
                (setq places (sshi-push-sym-sexps sym places))
                (forward-char))         ; over terminating ?\) of the binding
            (setq sym-start (point))  ; symbol (initialised implicitly to nil)
            (forward-sexp)
            (if (string= (buffer-substring sym-start (point)) sym)
                (push (cons sym-start (point)) places))
            (sshi-forward-WS)))
        (forward-char) (sshi-forward-WS)) ; over ?\) enclosing all bindings
        
       ((eq (char-after) ?\()
        (mark-sexp)
        (save-restriction
          (narrow-to-region (point) (mark))
          (setq places (append (sshi-list sym) places)))
        (sshi-forward-WS))

       (t (forward-sexp) (sshi-forward-WS))))
    (forward-char)                      ; over ?\)
    places))

(defvar sshi-symbol-hist nil
  "The symbol history list used by selective-setq")
(defun sshi-defun (arg sym face)
  "Highlight SYM each place within the current defun where it is setq'd or 
setc[ad]r'd.
With a prefix arg, remove the highlighting for SYM."
  (interactive
   (list
    current-prefix-arg
    (let* ((sym (symbol-at-point))
           (s (and sym (symbol-name sym))))
      (read-string
       "Symbol: "                               ; prompt
       s                                        ; initial-input
       'sshi-symbol-hist                        ; history
       s))
    (unless current-prefix-arg (hi-lock-read-face-name))))

  (save-excursion
    (save-restriction
      (narrow-to-defun)
      ;(beginning-of-defun)
      (goto-char (point-min))          ; beginning-of-defun drops a mark.  :-(
      (let ((places (sshi-list sym)))
        (mapc
         (lambda (elt)
           (let* (ov ovs)
             (setq ovs (overlays-at (car elt)))
             (while (and ovs
                         (setq ov (car ovs))
                         (not (overlay-get ov 'sshi)))
               (setq ovs (cdr ovs)))
             (when ovs
               (delete-overlay ov))
             (unless arg
               (setq ov (make-overlay (car elt) (cdr elt) nil nil nil))
               (overlay-put ov 'sshi t)
               (overlay-put ov 'face face))))
         places)))))

(define-key emacs-lisp-mode-map "\C-xwz" 'sshi-defun)
#########################################################################
> Davis

-- 
Alan Mackenzie (Nuremberg, Germany).




reply via email to

[Prev in Thread] Current Thread [Next in Thread]