On Thu, Dec 27 2012, Dan Lentz wrote:

I was just wondering if anyone has come up with any helpful elisp or slime/ swank customizations that are helpful to edit quasi quoted expressions (and therefore authoring macros).   I tend to get lost when things get much more deeply nested than ,', and so forth, and I was just thinking how useful it would be if there were some visual cues to help identify/correlate ' with the operative , and to indicate where the position of the cursor or current form represents in the layers of quotation -- maybe somewhat analogously to the concept of highlighting of the s-expression for paren matching.

Such a thing is probably pretty far beyond my current level of emacs skill, but I'm interested in any ideas or perhaps reasons why such a thing isn't practical, if that is the case.

This is a nice idea. I'm not aware of any other code that does this, but I couldn't resist to write my own. See below. It's a minor mode that can be turned on with M-x qlock-mode. For something like

`(aa aa `(bb bb `(cc cc)) ,d ,,ee ,',ee)

this will give "aa", "bb" and "cc" different colors. "d" is left alone (as it has level 0) and "ee" is again colored differently.

I'm not sure what to do with normal quotes ('). Also ,', and ,, are essentially the same for this mode, but those seems to be the trickiest part in practice.

The code is written from scratch (yesterday) and will contain bugs and is probably too slow for big files.

Helmut

;; -*- lexical-binding: t -*- ;;; qlock.el --- Minor mode to highlight quasiqoted forms. ;; ;; This mode higlights quasiquoted expresssion. For example in: ;; ;; `(aa aa `(bb bb `(cc cc)) ,d ,,ee ,',ff) ;; ;; "aa", "bb", "cc", "ee" and "ff" will be highlighted with special ;; faces. ;; ;; Use `M-x qlock-mode' to turn this mode on.

(eval-when-compile (require 'cl))

(defmacro qlock-when-debug (&rest _body) nil)

;; Nodes a the parse tree. (defstruct (qlock-node (:conc-name qlock-node.)) ;; Start position. Note: the start position of the first child may ;; be greater than this. start ;; End position end ;; What kind of node this is (kind :symbol :type (member :list :quote :unquote :unquote-splicing :hash-quote :symbol :string :character :comment)) ;; Child nodes form left to right children)

(defstruct (qlock-token (:conc-name qlock-token.)) start end kind)

(defstruct (qlock-cache (:conc-name qlock-cache.)) start end tick tree)

(defun qlock-skip-symbol (end) (skip-chars-forward "^ \n\t();"'`," end) (when (and (< (point) end) (eql (char-before) ?\) (not (eql (char-before (1- (point))) ?\))) (goto-char (1+ (point))) (qlock-skip-symbol end)))

(defun qlock-skip-string (end) (skip-chars-forward "^"" end) (cond ((and (< (point) end) (eql (char-before) ?\) (not (eql (char-before (1- (point))) ?\))) (goto-char (1+ (point))) (qlock-skip-string end)) (t (forward-char))))

(defun qlock-skip-comment (end) (skip-chars-forward "^\n" end))

;; Handle #<foo> reader macros. This is currently rather incomplete. (defun qlock-hash-token (end token) (cond ((= (point) end) (setf (qlock-token.end token) (point)) (setf (qlock-token.kind token) :hash)) (t (let ((c (char-after (point)))) (ecase c ((?' ?+ ?- ?\ ?.) (forward-char) (setf (qlock-token.end token) (point)) (setf (qlock-token.kind token) :hash-quote)))))))

;; Scan the next token. To avoid consing a fresh token for each call ;; the argument TOKEN is passed in an this function will fill in the ;; slots. (defun qlock-next-token (end token) (skip-chars-forward " \n\t" end) (setf (qlock-token.start token) (point)) (cond ((= (point) end) (setf (qlock-token.end token) (point)) (setf (qlock-token.kind token) :end)) (t (let ((c (char-after (point)))) (case c ((?( ?) ?' ?`) (setf (qlock-token.end token) (goto-char (1+ (point)))) (setf (qlock-token.kind token) c)) (?, (case (char-after (1+ (point))) (?@ (setf (qlock-token.end token) (goto-char (+ (point) 2))) (setf (qlock-token.kind token) :unquote-splicing)) (t (setf (qlock-token.end token) (goto-char (1+ (point)))) (setf (qlock-token.kind token) :unquote)))) (?" (forward-char) (qlock-skip-string end) (setf (qlock-token.end token) (point)) (setf (qlock-token.kind token) :string)) (?? (case (char-after (1+ (point))) (?\ (goto-char (min (+ (point) 3) end))) (t (goto-char (min (+ (point) 2) end)))) (setf (qlock-token.end token) (point)) (setf (qlock-token.kind token) :character)) (?; (qlock-skip-comment end) (setf (qlock-token.end token) (point)) (setf (qlock-token.kind token) :comment)) (?# (forward-char) (qlock-hash-token end token)) (t (qlock-skip-symbol end) (setf (qlock-token.end token) (point)) (setf (qlock-token.kind token) :symbol)))))) token)

(defun qlock-parse-sexp (end token) (let ((kind (qlock-token.kind token))) (ecase kind (?( (let ((children '()) (start (qlock-token.start token)) (more t) (result nil)) (while more (setq token (qlock-next-token end token)) (case (qlock-token.kind token) (?) (setq result (make-qlock-node :start start :end (qlock-token.end token) :kind :list :children (nreverse children))) (setq more nil)) (t (push (qlock-parse-sexp end token) children)))) result)) ((?' ?` :unquote :unquote-splicing :hash-quote) (let ((start (qlock-token.start token)) (sexp (qlock-parse-sexp end (qlock-next-token end token)))) (make-qlock-node :start start :end (qlock-token.end token) :kind (case kind (?' :quote) (?` :quasiquote) (t kind)) :children (list sexp)))) ((:symbol :string :character :comment) (make-qlock-node :start (qlock-token.start token) :end (qlock-token.end token) :kind kind)))))

;; Parse a S-expr and return a qlock-node for it. We assume that we ;; are at an appropriate start position. (defun qlock-parse (end) (let ((token (make-qlock-token))) (qlock-parse-sexp end (qlock-next-token end token))))

;; Compute the "quote level" for children of NODE. We increase the level ;; for ` and decrease it for , and ,@. (defun qlock-next-level (node level) (case (qlock-node.kind node) (:quasiquote (1+ level)) ((:unquote :unquote-splicing) (1- level)) (t level)))

;; Find the leftmost leaf that is in the interval from START to END. ;; Return a cons (LEAF . LEVEL) where LEVEL is the "quote level" of ;; the leaf. (defun qlock-find-leftmost-leaf (node start end level) (cond ((qlock-node.children node) (let ((next-level (qlock-next-level node level))) (loop for child in (qlock-node.children node) thereis (and (< start (qlock-node.end child)) (qlock-find-leftmost-leaf child start end next-level))))) ((and (<= start (qlock-node.start node)) (<= (qlock-node.end node) end)) (cons node level)) (t nil)))

;; Buffer local variable to cache the parse tree. (defvar qlock-cache nil)

;; Does the current cache include POSITION? (defun qlock-cached-p (position) (and qlock-cache (<= (- (buffer-chars-modified-tick) (qlock-cache.tick qlock-cache)) 0) (<= (qlock-cache.start qlock-cache) position) (< position (qlock-cache.end qlock-cache))))

;; Return a match-data object as needed for set-match-data. The ;; result has 4 subexpressions corresponding to the different ;; quote-faces. Only one will be non-nil. (defun qlock-make-match-data (tree start end level) (macrolet ((frob (&rest tests) `(list (qlock-node.start tree) (qlock-node.end tree) ,@(loop for test in tests collect `(if ,test start) collect `(if ,test end))))) (frob (< level 0) (= level 1) (= level 2) (>= level 3))))

;; Search point in the cache for something that needs to be ;; highlighted. (defun qlock-search-in-cache (end) (let* ((tree (qlock-cache.tree qlock-cache))) (pcase (qlock-find-leftmost-leaf tree (point) end 0) (`(,leaf . ,level) (let* ((start (qlock-node.start leaf)) (end (qlock-node.end leaf)) (md (qlock-make-match-data tree start end level))) (set-match-data md) (goto-char (qlock-node.end leaf)))) (`nil (cond ((< (point) end) (forward-char) (qlock-search-quotation end)) (t (set-match-data nil) nil))))))

;; Parse starting from point and update qlock-cache. Return nil iff ;; we encounter a problem during parsing. (defun qlock-prepare-cache (search-start end) (let* ((parse-start (point)) (parse-end (ignore-errors (scan-sexps parse-start 1))) (_ (qlock-when-debug (message "parse: %d-%s" parse-start parse-end))) (tree (and parse-end (qlock-parse parse-end)))) (add-text-properties (min parse-start search-start) (or parse-end end) '(font-lock-multiline t)) (when tree (assert (< search-start (qlock-node.end tree))) (setq qlock-cache (make-qlock-cache :start (min parse-start search-start) :end parse-end :tree tree :tick (buffer-chars-modified-tick))) (qlock-when-debug (message "set cache: %d-%d" parse-start parse-end)) (goto-char search-start) (assert (qlock-cached-p search-start) () "Search start not cached: %d" search-start) t)))

;; A quick check to see if the region from point to END contains ;; backquoted stuff. (defun qlock-parsing-needed-p (end) (let ((again t)) (while (and again (< (point) end)) (skip-chars-forward "^`," end) (cond ((let ((ppss (syntax-ppss))) (or (nth 3 ppss) ; inside string (nth 4 ppss))) ; inside comment (skip-chars-forward "`," end)) ((< (point) end) (setq again nil)))) (< (point) end)))

;; This function is called by font-lock mode. (defun qlock-search-quotation (end) (qlock-when-debug (message "point: %s end: %s tick: %d" (point) end (buffer-chars-modified-tick))) (let ((point (point))) (cond ((qlock-cached-p point) (qlock-search-in-cache end)) ((qlock-parsing-needed-p end) (funcall syntax-begin-function) (when (qlock-prepare-cache point end) (qlock-search-quotation end))) (t nil))))

(defgroup qlock nil "Customization for qlock-mode." :group 'lisp)

(defface qlock-negative-level '((t :inherit font-lock-warning-face)) "Face for negative quote level. That's typically a bug." :group 'qlock)

(defface qlock-level-1 '((((type graphic)) :inherit italic :italic t) (((type tty)) :foreground "black" :bold t)) "Face for one level of `." :group 'qlock)

(defface qlock-level-2 '((((type graphic)) :inherit font-lock-builtin-face :italic t) (((type tty)) :foreground "magenta" :bold t)) "Face for tow levels of ``." :group 'qlock)

(defface qlock-level-3 '((((type graphic)) :inherit font-lock-builtin-face :italic t :bold t) (((type tty)) :foreground "cyan" :bold t)) "Face for three or more level of ```." :group 'qlock)

(defvar qlock-font-lock-keywords '((qlock-search-quotation . ((1 'qlock-negative-level t t) (2 'qlock-level-1 prepend t) (3 'qlock-level-2 prepend t) (4 'qlock-level-3 prepend t)))))

(define-minor-mode qlock-mode "Minor mode to highlight quasiqoted forms." :init-value nil :lighter " `" :group 'qlock (cond (qlock-mode (make-local-variable 'qlock-cache) (font-lock-add-keywords nil qlock-font-lock-keywords)) (t (setq qlock-cache nil) (font-lock-remove-keywords nil qlock-font-lock-keywords))) (font-lock-fontify-buffer))

(qlock-when-debug (defun foo (x) `(aa aa `(bb bb `(cc cc)) ,d ,,e ,',f)))

(provide 'qlock)