qq-highlight.el

;;; -*- lexical-binding: t -*-

;;; qq-highlight.el

;;; Provides a function that temporarily highlights Lisp code
;;; templates (quasi-quotations) to make them easier to follow.
;;;
;;; Author: Mihai Bazon <mihai.bazon@gmail.com>, 2013.
;;; This file is public domain.
;;;
;;; M-x qq-highlight (M-`) to highlight the toplevel expression
;;; M-x qq-unhighlight (C-M-`) to remove the highlighting
;;;
;;; Highlighting is also automatically removed when the buffer is
;;; modified.
;;;
;;; The colors are designed for a dark background.  Change them in the
;;; list below.  It supports multiple levels of nested quasi-quoting
;;; (3 should suffice, but for pathological cases feel free to add
;;; more).

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

(defvar qq-highlight-colors '("#aaaacc" "#88bb88" "#bb8866"))

(put '%qq-highlight-overlay 'qq-highlight t)
(put '%qq-highlight-overlay 'face '((:foreground "#888888")))
(put '%qq-highlight-overlay 'evaporate t)

(defun %qq-highlight-onchange (begin end)
  (declare (ignore begin end))
  (qq-unhighlight))

(defun qq-unhighlight ()
  (interactive)
  (remove-overlays (point-min) (point-max) 'qq-highlight t)
  (remove-hook 'before-change-functions '%qq-highlight-onchange t))

(defun qq-highlight ()
  (interactive)
  (qq-unhighlight)
  (save-excursion
    (beginning-of-defun)
    (qq-highlight-doit nil 0 nil)
    (add-hook 'before-change-functions '%qq-highlight-onchange t t)))

(defun qq-highlight-break-overlay (start end &optional all)
  (let ((highlight (sort (remove-if-not (lambda (o)
                                          (overlay-get o 'qq-highlight))
                                        (overlays-at start))
                         (lambda (a b)
                           (> (overlay-get a 'qq-highlight-level)
                              (overlay-get b 'qq-highlight-level))))))
    (dolist (o highlight)
      (let ((v (copy-overlay o)))
        (move-overlay v end (overlay-end o))
        (move-overlay o (overlay-start o) start))
      (unless all (return)))))

(defun qq-highlight-doit (comma level skip)
  (let ((start (point))
        (limit (save-excursion
                 (forward-sexp)
                 (point))))
    (cond
     (comma
      (qq-highlight-break-overlay start limit))
     ((> level 0)
      (let* ((o (make-overlay start limit))
             (i (1- (min (length qq-highlight-colors) level)))
             (color (elt qq-highlight-colors i)))
        (overlay-put o 'category '%qq-highlight-overlay)
        (overlay-put o 'face `((:foreground ,color)))
        (overlay-put o 'qq-highlight-level level)
        ;; (overlay-put o 'before-string (format "<%d>" level))
        ;; (overlay-put o 'after-string (format "</%d>" level))
        )))
    (when skip (forward-char))
    (while (< (point) limit)
      (cond ((looking-at "#\\\\.")
             (forward-char 3))
            ((looking-at "`")
             (qq-highlight-doit nil (1+ level) t))
            ((looking-at "'")
             (if (= level 0)
                 (overlay-put (make-overlay (point) (progn
                                                      (forward-sexp)
                                                      (point)))
                              'category '%qq-highlight-overlay)
               (forward-char)))
            ((looking-at ",")
             (qq-highlight-doit t (1- level) t))
            ((looking-at "\"")
             (forward-sexp))
            ((looking-at ";")
             (qq-highlight-break-overlay
              (point)
              (progn (search-forward-regexp "$") (point))))
            ((eobp)
             (setf limit 0))
            (t
             (forward-char))))))

(define-key lisp-mode-shared-map (kbd "M-`") 'qq-highlight)
(define-key lisp-mode-shared-map (kbd "C-M-`") 'qq-unhighlight)

;; Local Variables:
;; byte-compile-warnings: (not cl-functions)
;; End: