New utility function cider-add-face

Author: vspinu

cider-util.el

@@ -309,6 +309,30 @@ Unless you specify a BUFFER it will default to the current one."
 (define-button-type 'cider-plain-button
   'face nil)
 
+(defun cider-add-face (regexp face &optional foreground-only sub-expr object)
+  "Propertize all occurrences of REGEXP with FACE.
+If FOREGROUND-ONLY is non-nil, change only the foreground of matched
+regions.  SUB-EXPR is a sub-expression of REGEXP to be
+propertized (defaults to 0).  OBJECT is an object to be
+propertized (defaults to current buffer)."
+  (setq sub-expr (or sub-expr 0))
+  (when (and regexp face)
+    (let ((beg 0)
+          (end 0))
+      (with-current-buffer (or (and (bufferp object) object)
+                               (current-buffer))
+        (while (if (stringp object)
+                   (string-match regexp object end)
+                 (re-search-forward regexp nil t))
+          (setq beg (match-beginning sub-expr)
+                end (match-end sub-expr))
+          (if foreground-only
+              (let ((face-spec (list (cons 'foreground-color
+                                           (face-attribute face :foreground nil t)))))
+                (font-lock-prepend-text-property beg end 'face face-spec object))
+            (put-text-property beg end 'face face object)))))))
+
+
 ;;; Colors
 
 (defun cider-scale-color (color scale)

test/cider-util-tests.el

@@ -218,3 +218,37 @@
             :not :to-be-truthy)
     (expect (cider-ansi-color-string-p "'an-ansi-str")
             :not :to-be-truthy)))
+
+(describe "cider-add-face"
+  :var (str)
+
+  (before-each
+    (setq str "aaa bbb\n cccc\n dddd"))
+
+  (describe "works in strings"
+    (it "fontifies with correct face"
+      (cider-add-face "c+" 'font-lock-comment-face nil nil str)
+      (expect (get-pos-property 1 'face str)
+              :to-be nil)
+      (expect (get-pos-property 10 'face str)
+              :to-be 'font-lock-comment-face))
+    (it "fontifies foreground with correct face"
+      (cider-add-face "b+" 'font-lock-comment-face t nil str)
+      (expect (get-pos-property 5 'face str)
+              :to-equal `((foreground-color . ,(face-attribute 'font-lock-comment-face
+                                                               :foreground nil t)))))
+    (it "fontifies sub-expression correctly"
+      (cider-add-face "\\(a\\)aa" 'font-lock-comment-face nil 1 str)
+      (expect (get-pos-property 0 'face str)
+              :to-be 'font-lock-comment-face)
+      (expect (get-pos-property 1 'face str)
+              :to-be nil)))
+
+  (describe "works in buffers"
+    (it "fontifies with correct face"
+      (with-temp-buffer
+        (insert "aaa bbb\n cccc\n ddddd")
+        (goto-char 1)
+        (cider-add-face "c+" 'font-lock-comment-face)
+        (expect (get-pos-property 11 'face)
+                :to-be 'font-lock-comment-face)))))