Skip to content

Commit

Permalink
Workaround for `ansi-color-apply' Emacs bug#53808 (#3154)
Browse files Browse the repository at this point in the history 
Enabled only in Emacs versions < 29.

https://debbugs.gnu.org/cgi/bugreport.cgi?bug=53808.

Also fixed a couple of old linter docstring warnings.
  • Loading branch information
@ikappaki
ikappaki authored Mar 5, 2022
1 parent 223bd60 commit 398b370
Show file tree
Hide file tree
Showing 4 changed files with 118 additions and 24 deletions.
2 changes: 1 addition & 1 deletion cider-mode.el
View file
Original file line number Diff line number Diff line change
Expand Up @@ -765,7 +765,7 @@ with the given LIMIT."
value))

(defun cider--compile-font-lock-keywords (symbols-plist core-plist)
"Return a list of font-lock rules for symbols."
"Return a list of font-lock rules for symbols in SYMBOLS-PLIST, CORE-PLIST."
(let ((cider-font-lock-dynamically (if (eq cider-font-lock-dynamically t)
'(function var macro core deprecated)
cider-font-lock-dynamically))
Expand Down
2 changes: 1 addition & 1 deletion cider-repl-history.el
View file
Original file line number Diff line number Diff line change
Expand Up @@ -344,7 +344,7 @@ case return nil."
(error "No CIDER history item here")))))

(defun cider-repl-history-current-string (pt &optional no-error)
"Find the string to insert into the REPL by looking for the overlay at PT
"Find the string to insert into the REPL by looking for the overlay at PT.
Might error unless NO-ERROR set."
(let ((o (cider-repl-history-target-overlay-at pt t)))
(if o
Expand Down
59 changes: 49 additions & 10 deletions cider-repl.el
View file
Original file line number Diff line number Diff line change
Expand Up @@ -593,13 +593,51 @@ Return the position of the prompt beginning."
(set-marker cider-repl-prompt-start-mark prompt-start)
prompt-start))))

(defun cider-repl--flush-ansi-color-context ()
"Flush ansi color context after printing.
When there is a possible unfinished ansi control sequence,
`ansi-color-context` maintains this list."
(when (and ansi-color-context (stringp (cadr ansi-color-context)))
(insert-before-markers (cadr ansi-color-context))
(setq ansi-color-context nil)))
(defun cider-repl--ansi-color-apply (string)
"Like `ansi-color-apply', but does not withhold non-SGR seqs found in STRING.
Workaround for Emacs bug#53808 whereby partial ANSI control seqs present in
the input stream may block the whole colorization process."
(let* ((result (ansi-color-apply string))

;; The STRING may end with a possible incomplete ANSI control seq which
;; the call to `ansi-color-apply' stores in the `ansi-color-context'
;; fragment. If the fragment is not an incomplete ANSI color control
;; sequence (aka SGR seq) though then flush it out and appended it to
;; the result.
(fragment-flush?
(when-let (fragment (and ansi-color-context (cadr ansi-color-context)))
(save-match-data
;; Check if fragment is indeed an SGR seq in the making. The SGR
;; seq is defined as starting with ESC followed by [ followed by
;; zero or more [:digit:]+; followed by one or more digits and
;; ending with m.
(when (string-match
(rx (sequence ?\e
(? (and (or ?\[ eol)
(or (+ (any (?0 . ?9))) eol)
(* (sequence ?\; (+ (any (?0 . ?9)))))
(or ?\; eol)))))
fragment)
(let* ((sgr-end-pos (match-end 0))
(fragment-matches-whole? (or (= sgr-end-pos 0)
(= sgr-end-pos (length fragment)))))
(when (not fragment-matches-whole?)
;; Definitely not an partial SGR seq, flush it out of
;; `ansi-color-context'.
t)))))))

(if (not fragment-flush?)
result

(progn
;; Temporarily replace the ESC char in the fragment so that is flushed
;; out of `ansi-color-context' by `ansi-color-apply' and append it to
;; the result.
(aset (cadr ansi-color-context) 0 ?\0)
(let ((result-fragment (ansi-color-apply "")))
(aset result-fragment 0 ?\e)
(concat result result-fragment))))))

(defvar-local cider-repl--ns-forms-plist nil
"Plist holding ns->ns-form mappings within each connection.")
Expand Down Expand Up @@ -672,7 +710,9 @@ namespaces. STRING is REPL's output."
(put-text-property 0 (length string) 'help-echo 'cider-locref-help-echo string)
string)

(defvar cider-repl-preoutput-hook '(ansi-color-apply
(defvar cider-repl-preoutput-hook `(,(if (< emacs-major-version 29)
'cider-repl--ansi-color-apply
'ansi-color-apply)
cider-repl-highlight-current-project
cider-repl-highlight-spec-keywords
cider-repl-add-locref-help-echo)
Expand Down Expand Up @@ -729,8 +769,7 @@ Before inserting, run `cider-repl-preoutput-hook' on STRING."
'font-lock-face face
'rear-nonsticky '(font-lock-face)))
(setq string (cider-run-chained-hook 'cider-repl-preoutput-hook string))
(insert-before-markers string)
(cider-repl--flush-ansi-color-context))
(insert-before-markers string))
(when (and (= (point) cider-repl-prompt-start-mark)
(not (bolp)))
(insert-before-markers "\n")
Expand Down
79 changes: 67 additions & 12 deletions test/cider-repl-tests.el
View file
Original file line number Diff line number Diff line change
Expand Up @@ -106,30 +106,71 @@
(cider-repl--emit-output (current-buffer) "a\n" 'cider-repl-stdout-face)
(cider-repl--emit-output (current-buffer) "b\n" 'cider-repl-stdout-face)
(cider-repl--emit-output (current-buffer) "c\n" 'cider-repl-stdout-face)
(cider-repl--emit-output (current-buffer) "d\n" 'cider-repl-stdout-face)
;; split at ESC
(cider-repl--emit-output (current-buffer) "" 'cider-repl-stdout-face)
(cider-repl--emit-output (current-buffer) "[32md\n" 'cider-repl-stdout-face)
;; split at ESC [
(cider-repl--emit-output (current-buffer) "[" 'cider-repl-stdout-face)
(cider-repl--emit-output (current-buffer) "33me\n" 'cider-repl-stdout-face)

(expect (buffer-string) :to-equal "a\nb\nc\nd\n")
;; split at ESC [n
(cider-repl--emit-output (current-buffer) "[3" 'cider-repl-stdout-face)
(cider-repl--emit-output (current-buffer) "1mf\n" 'cider-repl-stdout-face)

;; split at ESC [nm
(cider-repl--emit-output (current-buffer) "" 'cider-repl-stdout-face)
(cider-repl--emit-output (current-buffer) "g\n" 'cider-repl-stdout-face)

;; split at ESC [n;
(cider-repl--emit-output (current-buffer) "[1;" 'cider-repl-stdout-face)
(cider-repl--emit-output (current-buffer) "33mh\n" 'cider-repl-stdout-face)

;; split at ESC [n;n
(cider-repl--emit-output (current-buffer) "[0;31" 'cider-repl-stdout-face)
(cider-repl--emit-output (current-buffer) "mi\n" 'cider-repl-stdout-face)

;; split at ESC [n;nm
(cider-repl--emit-output (current-buffer) "" 'cider-repl-stdout-face)
(cider-repl--emit-output (current-buffer) "j\n" 'cider-repl-stdout-face)

(expect (buffer-substring-no-properties (point-min) (point-max))
:to-equal "a\nb\nc\nd\ne\nf\ng\nh\ni\nj\n")
(expect (get-text-property 1 'font-lock-face)
:to-equal '(foreground-color . "black"))
(expect (get-text-property 3 'font-lock-face)
:to-equal 'cider-repl-stdout-face)
(expect (get-text-property 5 'font-lock-face)
:to-equal '(foreground-color . "red3"))
(expect (get-text-property 7 'font-lock-face)
:to-equal '(foreground-color . "red3"))))))
:to-equal '(foreground-color . "green3"))
(expect (get-text-property 9 'font-lock-face)
:to-equal '(foreground-color . "yellow3"))
(expect (get-text-property 11 'font-lock-face)
:to-equal '(foreground-color . "red3"))
(expect (get-text-property 13 'font-lock-face)
:to-equal '(foreground-color . "green3"))
(expect (get-text-property 15 'font-lock-face)
:to-equal '((foreground-color . "yellow3") bold))
(expect (get-text-property 17 'font-lock-face)
:to-equal '(foreground-color . "red3"))
(expect (get-text-property 19 'font-lock-face)
:to-equal '((foreground-color . "green3") italic))
))))

(defun simulate-cider-output (s property)
"Return properties from `cider-repl--emit-output'.
PROPERTY should be a symbol of either 'text, 'ansi-context or
'properties."
(with-temp-buffer
(with-testing-ansi-table cider-testing-ansi-colors-vector
(cider-repl-reset-markers)
(cider-repl--emit-output (current-buffer) s nil))
(pcase property
(`text (substring-no-properties (buffer-string)))
(`ansi-context ansi-color-context)
(`properties (substring (buffer-string))))))
(let ((strings (if (listp s) s (list s))))
(with-temp-buffer
(with-testing-ansi-table cider-testing-ansi-colors-vector
(cider-repl-reset-markers)
(dolist (s strings)
(cider-repl--emit-output (current-buffer) s nil)))
(pcase property
(`text (substring-no-properties (buffer-string)))
(`ansi-context ansi-color-context)
(`properties (substring (buffer-string)))))))

(describe "cider-repl--emit-output"
(it "prints simple strings"
Expand All @@ -142,7 +183,21 @@ PROPERTY should be a symbol of either 'text, 'ansi-context or
(expect (simulate-cider-output "\033hi" 'text)
:to-equal "\033hi\n")
(expect (simulate-cider-output "\033hi" 'ansi-context)
:to-equal nil)))
:to-equal nil)

;; Informational: Ideally, we would have liked any non-SGR
;; sequence to appear on the output verbatim, but as per the
;; `ansi-color-apply' doc string, they are removed
;;
;; """Translates SGR control sequences into text properties.
;; Delete all other control sequences without processing them."""
;;
;; e.g.:
(expect (simulate-cider-output
"\033[hi" 'text) :to-equal "i\n")
(expect (simulate-cider-output
'("\033[" "hi") 'text) :to-equal "i\n")
))

(describe "when the escape code is valid"
(it "preserves the context"
Expand Down

0 comments on commit 398b370

Please sign in to comment.