From 5e76413a124d1242a443a3b7e070d28b0eed7306 Mon Sep 17 00:00:00 2001 From: "Paul M. Rodriguez" Date: Wed, 27 Nov 2024 17:19:05 -0600 Subject: [PATCH] Rework colorized output --- scripts/colorize.lisp | 21 ++++ tty.lisp | 236 ++++++++++++++++++++++++++++++++++++------ 2 files changed, 227 insertions(+), 30 deletions(-) create mode 100644 scripts/colorize.lisp diff --git a/scripts/colorize.lisp b/scripts/colorize.lisp new file mode 100644 index 0000000..22241c8 --- /dev/null +++ b/scripts/colorize.lisp @@ -0,0 +1,21 @@ +(defpackage :kiln/scripts/colorize + (:use :cl :alexandria :serapeum) + (:local-nicknames + (:tty :kiln/tty)) + (:documentation "Colorize output with ANSI, VGA, or RGB colors.")) +(in-package :kiln/scripts/colorize) + +(defun main (args) + (destructuring-bind (color . args) args + (let ((color + (if (string^= "#" color) + (if (length= color 7) + (let ((red (parse-integer color :start 1 :end 3 :radix 16)) + (green (parse-integer color :start 3 :end 5 :radix 16)) + (blue (parse-integer color :start 5 :radix 16))) + (tty:rgb red green blue)) + (error "Invalid hex code: ~a" color)) + (or (find-keyword (string-upcase color)) + (error "Unknown color: ~a" color))))) + (dolist (arg args) + (format t "~/tty:color/~a~/tty:color/~%" color arg nil))))) diff --git a/tty.lisp b/tty.lisp index 25aa8e6..dead7f7 100644 --- a/tty.lisp +++ b/tty.lisp @@ -1,27 +1,90 @@ (defpackage :kiln/tty (:documentation "Utilities for terminal output") + (:nicknames :kiln-tty) (:use :cl :alexandria :named-readtables - :serapeum) + :serapeum + :trivia) (:local-nicknames (:interpol :cl-interpol)) + (:shadow :@) (:export :beep :clear-line - :bold - :green - :red - :tty? - :yellow)) + :color + :colour + :colorize + :colourise + :effect + :rgb + :stream-tty? + :tty?)) (in-package :kiln/tty) (in-readtable :interpol-syntax) -(defun clear-line (stream) - (when (tty?) - (write-string #?"\x1b[2K" stream) - (force-output stream))) +(deftype color-policy () + '(member :always :never :auto)) + +(defvar *color* :auto) +(declaim (type color-policy *color*)) + +(-> stream-tty? (stream (member :input :output)) + (values boolean boolean)) +(defun stream-tty? (stream direction) + "Is STREAM a tty? +DIRECTION should be :input or :output. + +Returns two booleans: whether the stream was a TTY, and a second value +for confidence (T if sure, NIL if unsure)." + (declare (stream stream) + ((member :input :output) direction)) + (typecase stream + (synonym-stream + (stream-tty? + (symbol-value (synonym-stream-symbol stream)) + direction)) + (two-way-stream + (ecase direction + (:input + (stream-tty? + (two-way-stream-input-stream stream) + direction)) + (:output + (stream-tty? + (two-way-stream-output-stream stream) + direction)))) + (broadcast-stream + (let ((streams (broadcast-stream-streams stream))) + (match streams + (() (values nil t)) + ((list stream) + (stream-tty? stream direction)) + ((list* stream more-streams) + (multiple-value-bind (initial-tty? initial-confidence?) + (stream-tty? stream direction) + (mvfold (lambda (tty? sure stream) + (multiple-value-bind (stream-tty? sure-of-stream?) + (stream-tty? stream direction) + (values (and tty? stream-tty?) + (and sure sure-of-stream?)))) + more-streams + initial-tty? + initial-confidence?)))))) + (otherwise + #+ccl + (if-let (fd (ccl::stream-device stream direction)) + (values (= 1 (ccl::isatty fd)) t) + (values nil nil)) + #+sbcl + (if (typep stream 'sb-sys:fd-stream) + (values + (= 1 (sb-unix:unix-isatty (sb-sys:fd-stream-fd stream))) + t) + (values nil nil)) + #-(or ccl sbcl) + (values nil nil)))) (defun tty? () "Return T if there is a controlling TTY." @@ -31,29 +94,142 @@ t) (file-error () nil))) -(declaim (ftype (-> (string) string) - red green yellow bold)) +(defun clear-line (stream &key return) + (when (stream-tty? stream :output) + (write-string #?"\x1b[2K" stream) + (when return + (write-char #\Return stream)) + (force-output stream))) -(defun red (s) - (if (no (tty?)) s - (string+ #?"\x1b[0;31m" s #?"\x1b[0m"))) +(defun beep (&key (stream *standard-output*)) + (write-char #\Bel stream) + (finish-output stream)) -(defun green (s) - (if (no (tty?)) s - (string+ #?"\x1b[0;32m" s #?"\x1b[0m"))) +(defconstructor rgb + (red octet) + (green octet) + (blue octet)) -(defun orange (s) - (if (no (tty?)) s - (string+ #?"\x1b[0;35m" s #?"\x1b[0m"))) +(deftype color () + '(or symbol octet rgb)) -(defun yellow (s) - (if (no (tty?)) s - (string+ #?"\x1b[1;33m" s #?"\x1b[0m"))) +(defconst +colors+ + (dictq + nil 0 + :off 0 + :bold 1 + :bold-off 21 + :faint 2 + :faint-off 22 + :dim 2 + :dim-off 22 + :italic 3 + :italic-off 23 + :underline 4 + :underline-off 24 + :slow-blink 5 + :slow-blink-off 25 + :blink 5 + :blink-off 25 + :fast-blink 6 + :fast-blink-off 25 + :reverse 7 + :reverse-off 27 + :reverse-video 7 + :reverse-video-off 27 + :conceal 8 + :conceal-off 28 + :hide 8 + :hide-off 28 + :black 30 + :black-bg 40 + :red 31 + :red-bg 41 + :green 32 + :green-bg 42 + :yellow 33 + :yellow-bg 43 + :blue 34 + :blue-bg 44 + :magenta 35 + :magenta-bg 45 + :cyan 36 + :cyan-bg 46 + :white 37 + :white-bg 47 + :default 39 + :default-bg 49 + :bright-black 90 + :bright-black-bg 100 + :bright-red 91 + :bright-red-bg 101 + :bright-green 92 + :bright-green-bg 102 + :bright-yellow 93 + :bright-yellow-bg 103 + :bright-blue 94 + :bright-blue-bg 104 + :bright-magenta 95 + :bright-magenta-bg 105 + :bright-cyan 96 + :bright-cyan-bg 106 + :bright-white 97 + :bright-white-bg 107 + :bright-default 99 + :bright-default-bg 109)) -(defun bold (s) - (if (no (tty?)) s - (string+ #?"\x1b[1m" s #?"\x1b[0m"))) +(defun color (stream color &optional colon? at-sign?) + "Write an ANSI escape for a color/effect to STREAM. -(defun beep (&key (stream *standard-output*)) - (write-char #\Bel stream) - (finish-output stream)) +COLOR can be null (to reset formatting), a keyword (for a named ANSI +color/effect), an integer (for a VGA color), or an instance of +`kiln/tty:rgb' for an RGB color. + +This function is designed so it can be invoked with the ~/ format +control: + + (format t \"~/kiln-tty:color/This is red~/kiln-tty:color/This is not\" + :red + nil) + +By default, escapes are only written if STREAM can be determined to be +a TTY. You can pass non-nil `colon?' to force outputting colors, or +bind `kiln/tty:*color*' to `:always'." + (declare (ignore at-sign?) + (color color)) + (let ((code + (etypecase-of color color + (octet + (fmt "38;5;~a" color)) + (symbol + (or (gethash color +colors+) + (error "Unknown color: ~a" color))) + (rgb + (multiple-value-call #'fmt "38;2;~a;~a;~a" + (ematch color + ((rgb red green blue) + (values red green blue)))))))) + (when (ecase-of color-policy *color* + (:never nil) + (:always t) + (:auto + (or colon? + (stream-tty? stream :output)))) + (format stream #?"\x1b[~am" code)))) + +(defsubst colour (stream color &optional color? at-sign) + "Alias for `color." + (color stream color color? at-sign)) + +(defstruct-read-only + (colorize + (:constructor colorize (color object)) + (:constructor colourise (color object))) + "Wrap an object with a color." + (color :type color) + (object :type t)) + +(defmethod print-object ((wrapper colorize) stream) + (format stream "~/kiln-tty:color/" (colorize-color wrapper)) + (print-object (colorize-object wrapper) stream) + (format stream "~/kiln-tty:color/" nil))