Mark clojure comment blocks in fringes

clojure-comment-block.el

;;; clojure-comment-block.el --- mark comment blocks in the fringe  -*- lexical-binding: t; -*-

;; This is free and unencumbered software released into the public domain.
;;
;; Anyone is free to copy, modify, publish, use, compile, sell, or
;; distribute this software, either in source code form or as a compiled
;; binary, for any purpose, commercial or non-commercial, and by any
;; means.
;;
;; In jurisdictions that recognize copyright laws, the author or authors
;; of this software dedicate any and all copyright interest in the
;; software to the public domain. We make this dedication for the benefit
;; of the public at large and to the detriment of our heirs and
;; successors. We intend this dedication to be an overt act of
;; relinquishment in perpetuity of all present and future rights to this
;; software under copyright law.
;;
;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
;; IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY CLAIM, DAMAGES OR
;; OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE,
;; ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
;; OTHER DEALINGS IN THE SOFTWARE.
;;
;; For more information, please refer to <http://unlicense.org/>

;;; Code:

(defface clojure-comment-block-face
  '((((class color) (background dark)) :background "MediumPurple4")
    (((class color) (background light)) :background "MediumPurple1"))
  "Face used for clojure comment blocks")

(define-fringe-bitmap 'clojure-comment-fringe
  [#b0011100] ;; ..###..
  nil nil '(center repeated))

(defconst clojure--comment-fringe-spec
  (propertize " " 'display '(left-fringe clojure-comment-fringe clojure-comment-block-face)))

(defvar clojure-comment-block-repeat 2.0
  "Number of seconds between refreshing of comment block overlays.")

(defvar clojure-comment-block-timer nil
  "Timer used by clojure-comment-block-mode.")

(defun clojure--update-comment-overlays ()
  (when clojure-comment-block-mode
    (while-no-input
      ;; 1) make sure all overlays are at comment blocks
      (dolist (ov (overlays-in (window-start) (window-end)))
        (when (overlay-get ov 'clojure-comment)
          (save-excursion
            (goto-char (overlay-start ov))
            (if  (looking-at "^(comment")
                (move-overlay ov (point) (scan-sexps (point) 1))
              (delete-overlay ov)))))
      ;; 2) make sure all comment blocks have overlays
      (save-excursion
        (goto-char (window-start))
        (when (not (= 0 (nth 0 (syntax-ppss))))
          (let ((beginning-of-defun-function nil))
            (beginning-of-defun)))
        (while (and (< (point) (min (point-max) (window-end)))
                    (search-forward-regexp "^(comment" (window-end) 'noerror))
          (unless (seq-some (lambda (ov) (overlay-get ov 'clojure-comment))
                            (overlays-at (point)))
            (let* ((beg (match-beginning 0))
                   (end (save-excursion (goto-char beg)
                                        (forward-sexp 1)
                                        (point)))
                   (ov (make-overlay beg end))
                   (ov2 (make-overlay beg (match-end 0))))
              (overlay-put ov 'clojure-comment t)
              (overlay-put ov 'evaporate t)
              (overlay-put ov 'line-prefix clojure--comment-fringe-spec))))))))

(defun clojure-delete-comment-overlays ()
  (dolist (ov (overlays-in (point-min) (point-max)))
    (when (overlay-get ov 'clojure-comment)
      (delete-overlay ov))))

(define-minor-mode
  clojure-comment-block-mode
  "Visually set off comment blocks with a line prefix.
 Only operates on visible forms in the window."
  nil nil nil
  (when clojure-comment-block-timer
    (cancel-timer clojure-comment-block-timer))
  (clojure-delete-comment-overlays)
  (when clojure-comment-block-mode
    (progn
      (add-to-list 'font-lock-extra-managed-props 'line-prefix)
      (clojure--update-comment-overlays)
      (setq clojure-comment-block-timer
            (run-with-timer 0 clojure-comment-block-repeat
                            #'clojure--update-comment-overlays)))))

(add-hook 'clojure-mode-hook #'clojure-comment-block-mode)

(provide 'clojure-comment-block)

;;; clojure-comment-block.el ends here