;; -*- Mode: Emacs-Lisp; -*- ;; --------------------------------------------------------------------------- ;; Title: ANSI CSI Select Graphic Rendition for SLIME ;; Created: 2023-01-13 ;; Author: Gilbert Baumann ;; License: MIT style (see below) ;; --------------------------------------------------------------------------- ;; (c) copyright 2023 by Gilbert Baumann ;; Permission is hereby granted, free of charge, to any person obtaining ;; a copy of this software and associated documentation files (the ;; "Software"), to deal in the Software without restriction, including ;; without limitation the rights to use, copy, modify, merge, publish, ;; distribute, sublicense, and/or sell copies of the Software, and to ;; permit persons to whom the Software is furnished to do so, subject to ;; the following conditions: ;; ;; The above copyright notice and this permission notice shall be ;; included in all copies or substantial portions of the Software. ;; ;; 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 OR COPYRIGHT HOLDERS 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. ;; Somehow these cannot be buffer local, can they? (require'cl) (defvar slime-repl-output-face '(slime-repl-output-face)) (defvar slime-repl-output-extra-properties nil "Extra properties to set for output, used for sub- and superscript, as raising and lowering is a `display' property not a `face' property for reasons.") (defvar slime-repl-output-state nil "The current state of `slime-repl-emit', NIL means default state.") (defvar slime-repl-output-stash "" "Cummulated string not yet emitted with `slime-repl-emit'.") ;; The strategy is that we look at a piece of output and when there is ;; any ESC inside we switch to another mode and try to make sense of the ;; escape. ;; We keep the original SLIME-REPL-EMIT with a twist: It'll use the ;; value of `slime-repl-output-face' for its face. (defun slime-repl-emit (string) (let ((case-fold-search nil) p) (case slime-repl-output-state (:esc (setq slime-repl-output-stash (concat slime-repl-output-stash string)) (cond ((string-match "^\e\\[\\([\x20-\x3F]*\\)\\(.\\)" slime-repl-output-stash) (let ((params (match-string 1 slime-repl-output-stash)) (dir (match-string 2 slime-repl-output-stash)) (end (match-end 0))) (setq params (split-string params ";")) (unless end (error "Emacs is behaving funny indeed ~S ~S.")) (slime-repl-do-csi dir params) (setq slime-repl-output-state nil) (slime-repl-emit (subseq (prog1 slime-repl-output-stash (setq slime-repl-output-stash "")) end)))) ((string-match "^\e." string) ;; any other escape, just eat it (let ((end (match-end 0))) (slime-repl-emit (subseq (prog1 slime-repl-output-stash (setq slime-repl-output-stash "")) end)))))) (t (cond ((setq p (string-match "\e" string)) (slime-repl-emit-1 (subseq string 0 p)) (setq slime-repl-output-stash "" ;just in case slime-repl-output-state :esc) (slime-repl-emit (subseq string p))) (t (slime-repl-emit-1 string))))))) (defun slime-repl-do-csi (directive params) (cond ((equal "m" directive) (dolist (p params) (let ((p (and (string-match "^[0-9]+$" p) (string-to-number p)))) (case p (0 (setq slime-repl-output-face '(slime-repl-output-face)) (remf slime-repl-output-extra-properties 'display)) (1 (pushnew 'bold slime-repl-output-face)) ;; 2 faint (3 (pushnew 'italic slime-repl-output-face)) (4 (pushnew 'underline slime-repl-output-face)) ;; 5, 6 blink (7 (pushnew '(:inverse-video t) slime-repl-output-face)) ;; 8 hide ;; 9 strike-through (9 (pushnew '(:strike-through t) slime-repl-output-face :test 'equal)) ;; 10..19 font select (20 fraktur?) ;; 21 doubly underline ;; 22 normal intensity (22 (setq slime-repl-output-face (remove 'bold slime-repl-output-face))) ;; 23 neither bold, black-letter (how to set black-letter and what is it?) (23 (setq slime-repl-output-face (remove 'bold slime-repl-output-face))) ;; 24 not underlined (24 (setq slime-repl-output-face (remove 'underline slime-repl-output-face))) ;; 25 not blinking ;; 26 proportional spacing (27 (setq slime-repl-output-face (remove '(:inverse-video t) slime-repl-output-face))) ;; 28 not hidden ;; 29 not strike-through (29 (setq slime-repl-output-face (remove '(:strike-through t) slime-repl-output-face))) ;; 40..37 bg ;; 50 disable proportional (51 ;framed (pushnew '(:box t) slime-repl-output-face :test 'equal)) (52 ;encircled (pushnew '(:box t) slime-repl-output-face :test 'equal)) (53 ;overline (pushnew '(:overline t) slime-repl-output-face) :test 'equal) (54 ;neither framed or encircled (setq slime-repl-output-face (remove '(:box t) slime-repl-output-face))) (55 (setq slime-repl-output-face (remove '(:overline t) slime-repl-output-face))) ;; 58 underline color ;; 59 default underline color ;; ### The subscript and superscript faces come from TeX mode. (73 (setq slime-repl-output-face (remove 'subscript slime-repl-output-face)) (remf slime-repl-output-extra-properties 'display) (push '(raise 0.5) slime-repl-output-extra-properties) (push 'display slime-repl-output-extra-properties) (pushnew 'superscript slime-repl-output-face)) (74 (setq slime-repl-output-face (remove 'superscript slime-repl-output-face)) (remf slime-repl-output-extra-properties 'display) (push '(raise -0.5) slime-repl-output-extra-properties) (push 'display slime-repl-output-extra-properties) (pushnew 'subscript slime-repl-output-face)) (75 (remf slime-repl-output-extra-properties 'display) (setq slime-repl-output-face (remove 'superscript slime-repl-output-face)) (setq slime-repl-output-face (remove 'subscript slime-repl-output-face))) (t (cond ((or (<= 30 p 37) (<= 90 p 97) (<= 40 p 47) (<= 100 p 107) ) (slime-repl-set-ansi-color p)))))))))) (defun slime-repl-set-ansi-color (code) (let ((which :foreground)) (when (or (<= 40 code 47) (<= 100 code 107)) (setq which :background code (- code 10))) (let ((value (case code (30 "#000000") (31 "#C23621") (32 "#25BC24") (33 "#ADAD27") (34 "#492EE1") (35 "#D338D3") (36 "#33BBC8") (37 "#CBCCCD") (90 "#818383") (91 "#FC391F") (92 "#31E722") (93 "#EAEC23") (94 "#5833FF") (95 "#F935F8") (96 "#14F0F0") (97 "#E9EBEB")))) (setq slime-repl-output-face (remove-if (lambda (x) (and (consp x) (eq (car x) which))) slime-repl-output-face)) (when value (push (list which value) slime-repl-output-face))))) (defun slime-repl-emit-1 (string) ;; The original thing but for using the value of `slime-repl-output-face'. ;; "insert the string STRING in the output buffer" (with-current-buffer (slime-output-buffer) (save-excursion (goto-char slime-output-end) (slime-save-marker slime-output-start (slime-propertize-region `(face ,slime-repl-output-face ,@ slime-repl-output-extra-properties rear-nonsticky (face)) (insert-before-markers string) (when (and (<= (point) slime-repl-prompt-start-mark) (not (bolp))) (insert-before-markers "\n") (set-marker slime-output-end (1- (point))))))) (when slime-repl-popup-on-output (setq slime-repl-popup-on-output nil) (display-buffer (current-buffer))) (slime-repl-show-maximum-output)))