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

[Alan Mackenzie <acm@muc.de>]

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).