Use text properties instead of overlays for ANSI coloring

Author: rfkm

CHANGELOG.md

@@ -1,9 +1,11 @@
 # Changelog
 
-## master (unreleased)
-
 ## 0.10.1 / (unreleased)
 
+### Changes
+
+* [#1500](https://github.com/clojure-emacs/cider/pull/1500): Improve the performance of REPL buffers by using text properties instead of overlays for ANSI coloring.
+
 ### Bugs fixed
 
 * [#1480](https://github.com/clojure-emacs/cider/issues/1480): Fix an error in `cider-restart` caused by not using the REPL's buffer as the current connection when calling `cider-current-connection` from REPL buffer.
@@ -12,9 +14,8 @@
 * [#1466](https://github.com/clojure-emacs/cider/issues/1466): Correctly font-lock pretty-printed results in the REPL.
 * [#1475](https://github.com/clojure-emacs/cider/pull/1475): Fix `args-out-of-range` error in `cider--get-symbol-indent`.
 * [#1479](https://github.com/clojure-emacs/cider/pull/1479): Make paredit and `cider-repl-mode` play nice.
-* [#1452](https://github.com/clojure-emacs/cider/issues/1452): Prevent ANSI color overlays in the REPL buffer from being extended.
+* [#1452](https://github.com/clojure-emacs/cider/issues/1452): Fix wrong ANSI coloring in the REPL buffer.
 * [#1486](https://github.com/clojure-emacs/cider/issues/1486): Complete a partial fix in stacktrace font-locking.
-* [#1488](https://github.com/clojure-emacs/cider/pull/1488): Delete zombie overlays in the REPL buffer.
 * [#1482](https://github.com/clojure-emacs/cider/issues/1482): Clear nREPL sessions when a connection is closed.
 * [#1435](https://github.com/clojure-emacs/cider/issues/1435): Improve error display in cider-test.
 * [#1379](https://github.com/clojure-emacs/cider/issues/1379): Fix test highlighting at start of line.

cider-repl.el

@@ -469,34 +469,21 @@ If BOL is non-nil insert at the beginning of line."
           (goto-char position)
           ;; TODO: Review the need for bol
           (when (and bol (not (bolp))) (insert-before-markers "\n"))
-          (cider-propertize-region `(font-lock-face ,output-face
-                                                    rear-nonsticky (font-lock-face))
-            (insert-before-markers string)
-            (when (and (= (point) cider-repl-prompt-start-mark)
-                       (not (bolp)))
-              (insert-before-markers "\n")
-              (set-marker cider-repl-output-end (1- (point))))))))
+          (insert-before-markers (ansi-color-apply (propertize string
+                                                               'font-lock-face output-face
+                                                               'rear-nonsticky '(font-lock-face))))
+          (when (and (= (point) cider-repl-prompt-start-mark)
+                     (not (bolp)))
+            (insert-before-markers "\n")
+            (set-marker cider-repl-output-end (1- (point)))))))
     (cider-repl--show-maximum-output)))
 
 (defun cider-repl--emit-interactive-output (string face)
   "Emit STRING as interactive output using FACE."
   (with-current-buffer (cider-current-repl-buffer)
     (let ((pos (cider-repl--end-of-line-before-input-start))
           (string (replace-regexp-in-string "\n\\'" "" string)))
-      (cider-repl--emit-output-at-pos (current-buffer) string face pos t)
-      (ansi-color-apply-on-region pos (point-max))
-
-      ;; If the output has a trailing overlay created by ansi-color, it would be
-      ;; extended by the following outputs. To avoid this, ansi-color adds
-      ;; `ansi-color-freeze-overlay' to the `modification-hooks', but it never
-      ;; seems to be called. By using `insert-behind-hooks' instead, we can make
-      ;; it work. For more details, please see
-      ;; https://github.com/clojure-emacs/cider/issues/1452
-      (dolist (ov (overlays-at (1- (cider-repl--end-of-line-before-input-start))))
-        ;; Ensure ov is created by ansi-color
-        (when (and (member #'ansi-color-freeze-overlay (overlay-get ov 'modification-hooks))
-                   (not (member #'ansi-color-freeze-overlay (overlay-get ov 'insert-behind-hooks))))
-          (push #'ansi-color-freeze-overlay (overlay-get ov 'insert-behind-hooks)))))))
+      (cider-repl--emit-output-at-pos (current-buffer) string face pos t))))
 
 (defun cider-repl-emit-interactive-stdout (string)
   "Emit STRING as interactive output."
@@ -521,9 +508,7 @@ FORMAT is a format string to compile with ARGS and display on the REPL."
   "Using BUFFER, emit STRING font-locked with FACE.
 If BOL is non-nil, emit at the beginning of the line."
   (with-current-buffer buffer
-    (let ((pos (cider-repl--end-of-line-before-input-start)))
-      (cider-repl--emit-output-at-pos buffer string face cider-repl-input-start-mark bol)
-      (ansi-color-apply-on-region pos (point-max)))))
+    (cider-repl--emit-output-at-pos buffer string face cider-repl-input-start-mark bol)))
 
 (defun cider-repl-emit-stdout (buffer string)
   "Using BUFFER, emit STRING as standard output."

test/cider-tests.el

@@ -517,6 +517,23 @@
   (should (equal (cider-repl-prompt-abbreviated "some.pretty.long.namespace.name")
                  "s.p.l.n.name> ")))
 
+(ert-deftest test-cider-repl--emit-output-at-pos-with-ansi-code ()
+  (with-temp-buffer
+    (let* ((ansi-color-names-vector ["black" "red3" "green3" "yellow3" "blue2" "magenta3" "cyan3" "gray90"])
+           (ansi-color-map (ansi-color-make-color-map)))
+      (cider-repl-reset-markers)
+
+      (cider-repl--emit-output-at-pos (current-buffer) "a" 'cider-repl-stdout-face (point))
+      (cider-repl--emit-output-at-pos (current-buffer) "b" 'cider-repl-stdout-face (point))
+      (cider-repl--emit-output-at-pos (current-buffer) "c" 'cider-repl-stdout-face (point))
+      (cider-repl--emit-output-at-pos (current-buffer) "d" 'cider-repl-stdout-face (point))
+
+      (should (string= (buffer-string) "a\nb\nc\nd\n"))
+      (should (equal (get-text-property 1 'font-lock-face) '(foreground-color . "black")))
+      (should (equal (get-text-property 3 'font-lock-face) 'cider-repl-stdout-face))
+      (should (equal (get-text-property 5 'font-lock-face) '(foreground-color . "red3")))
+      (should (equal (get-text-property 7 'font-lock-face) '(foreground-color . "red3"))))))
+
 (ert-deftest test-cider--url-to-file ()
   (should (equal "/space test" (cider--url-to-file "file:/space%20test")))
   (should (equal "C:/space test" (cider--url-to-file "file:/C:/space%20test"))))