diff --git a/.travis.yml b/.travis.yml index 033c340..078eae1 100644 --- a/.travis.yml +++ b/.travis.yml @@ -1,13 +1,40 @@ -before_script: - - curl -O -L http://prdownloads.sourceforge.net/sbcl/sbcl-1.2.6-x86-64-linux-binary.tar.bz2 - - tar xjf sbcl-1.2.6-x86-64-linux-binary.tar.bz2 - - pushd sbcl-1.2.6-x86-64-linux/ && sudo bash install.sh && popd - - curl -O -L http://beta.quicklisp.org/quicklisp.lisp - - sbcl --load quicklisp.lisp --eval '(quicklisp-quickstart:install)' --eval '(quit)' - - curl -OL http://ccl.clozure.com/ftp/pub/release/1.10/ccl-1.10-linuxx86.tar.gz - - tar xzf ccl-1.10-linuxx86.tar.gz - - export PATH=`pwd`/ccl:$PATH -# - lx86cl64 -b --load quicklisp.lisp --eval '(progn (quicklisp-quickstart:install) (quit))' +language: common-lisp +sudo: false + +addons: + apt: + packages: + - libc6-i386 + - clisp + +env: + global: + - PATH=~/.roswell/bin:$PATH + - ROSWELL_INSTALL_DIR=$HOME/.roswell + matrix: + - LISP=sbcl-bin + - LISP=ccl-bin + - LISP=abcl + - LISP=clisp + - LISP=ecl + - LISP=cmucl + - LISP=alisp + +matrix: + allow_failures: + - env: LISP=clisp + - env: LISP=abcl + - env: LISP=ecl + - env: LISP=cmucl + - env: LISP=alisp + +install: + - curl -L https://raw.githubusercontent.com/snmsts/roswell/release/scripts/install-for-ci.sh | sh + +cache: + directories: + - $HOME/.roswell + - $HOME/.config/common-lisp script: - - ./ci-test-run.sh \ No newline at end of file + - ./testscr.ros diff --git a/README.md b/README.md index 45fad05..692cf6c 100644 --- a/README.md +++ b/README.md @@ -3,39 +3,57 @@ Because color in your terminal is nice. [![Build Status](https://travis-ci.org/pnathan/cl-ansi-text.svg?branch=master)](https://travis-ci.org/pnathan/cl-ansi-text) +Installation: `(ql:quickload :cl-ansi-text)` + ## Usage example - -```lisp -* (ql:quickload :cl-ansi-text) -;To load "cl-ansi-text": -; Load 1 ASDF system: -; cl-ansi-text -;; Loading "cl-ansi-text" -; => (:CL-ANSI-TEXT) -``` -The main macro is called `with-color`, which creates an enviroment where everything that is put on `stream` gets colored according to `color`. Color options are `:black`, `:red`, `:green`, `:yellow`, `:blue`, `:magenta`, `:cyan` and `:white`. You can also use a color structure from `CL-COLORS`, like `cl-colors:+red+`. +The main macro is `with-color`, which creates an enviroment where everything that is put on `stream` gets colored according to `color`. + +Color options comes in several forms. + +### Keyword Symbol + +Basic 8 colors in the 3-bit color mode are supported, which are `:black`, `:red`, `:green`, `:yellow`, `:blue`, `:magenta`, `:cyan` and `:white`. ```lisp -* (import 'cl-ansi-text:with-color) -; => T * (with-color (:red) (princ "Gets printed red...") (princ "and this too!")) ; Gets printed red...and this too! ; => "and this too!" ``` +### `CL-COLORS:RGB` and `CL-COLORS:HSV` object + +These are color structures from `CL-COLORS2` (a maintained fork of `CL-COLORS`). +`CL-COLORS2` has several constants e.g. `cl-colors:+red+` that holds the corresponding color values. +`CL-COLORS2` also supports useful blending operations on colors. +Note that `CL-COLORS2` library provides a package `CL-COLORS`, not `CL-COLORS2`. + +### Hex representation + +These are CSS-style color strings such as `"#FF0000"`. + +### Integer as a 24-bit color + +It treats an integer as a hex string. +The bottom 8 bit is used for the blue, the 8th to 16th bits are used for green, +the 16th to 24th bits are used for red. +Remaining bits are ignored. + +### List of numbers as a 24-bit color + +It takes a list of three numbers (RGB) between 0 and 256. + +## Function interface for printing in specific colors + +We provide shorthand functions for generating a colored strings: -There are also functions with the name of the colors, that return the string, colored: ```lisp -* (import 'cl-ansi-text:yellow) -; => T * (yellow "Yellow string") ; => "Yellow string" * (princ (yellow "String with yellow background" :style :background)) ; "String with yellow background" ; => "String with yellow background" -* (import 'cl-ansi-text:red) -; => T * (princ (concatenate 'string @@ -43,7 +61,9 @@ There are also functions with the name of the colors, that return the string, co ; Five test results went terribly wrong! ; => "Five test results went terribly wrong!" ``` -At any point, you can bind the `*enabled*` special variable to `nil`, and anything inside that binding will not be printed colorfully: + +You can bind the `*enabled*` special variable to `nil` to control the colorization: + ```lisp * (let (cl-ansi-text:*enabled*) (princ (red "This string is printed normally"))) @@ -51,90 +71,99 @@ At any point, you can bind the `*enabled*` special variable to `nil`, and anythi # API +## *Type* color-specifier + +``` lisp +(or unsigned-byte + (cons (real 0 256) + (cons (real 0 256) + (cons (real 0 256) + nil))) + cl-colors:rgb + cl-colors:hsv + term-colors + color-string) +``` -## BLUE - -Returns a string with the `blue'string denotation preppended and the `reset' string denotation appended. - -*enabled* dynamically controls the function. - -## MAGENTA - -Returns a string with the `magenta'string denotation preppended and the `reset' string denotation appended. - -*enabled* dynamically controls the function. - -## CYAN - -Returns a string with the `cyan'string denotation preppended and the `reset' string denotation appended. - -*enabled* dynamically controls the function. - -## GREEN - -Returns a string with the `green'string denotation preppended and the `reset' string denotation appended. - -*enabled* dynamically controls the function. +## *Type* term-colors -## WITH-COLOR +``` lisp +(member :black :red :green :yellow :blue :magenta :cyan :white) +``` -Writes out the string denoting a switch to `color`, executes body, -then writes out the string denoting a `reset`. +## *Type* color-string -*enabled* dynamically controls expansion.. +A string of length 3, 4, 6, or 7, that optionally starts with a `#`, and +the rest consists of 3 or 6 hexademical alphadigits (case-insensitive). -## YELLOW +## *Macro* with-color -Returns a string with the `yellow'string denotation preppended and the `reset' string denotation appended. +``` lisp +with-color (color &key (stream t) (effect :unset) (style :foreground)) &body body +``` -*enabled* dynamically controls the function. +Writes out the ANSI escape code string +denoting `effect`, `style`, and a switch to `color`, then executes `body`, +then writes out the string that resets the decoration. -## BLACK +## *Function* make-color-string -Returns a string with the `black'string denotation preppended and the `reset' string denotation appended. +``` lisp +make-color-string color &key (effect :unset) (style :foreground) enabled +``` -*enabled* dynamically controls the function. +Takes an object of `color-specifier` and returns a string sufficient to change to the given color. -## *ENABLED* +Colorization is controlled by *enabled* unless manually specified otherwise by `:enabled` keyword. -Turns on/off the colorization of functions +## *Function* black, red, green, yellow, blue, magenta, cyan, white -## MAKE-COLOR-STRING +Shortcut functions that takes a single argument, `string`, and returns a string +decorated by the corresponding color. -Takes either a cl-color or a list denoting the ANSI colors and -returns a string sufficient to change to the given color. +## *Special variable* `*enabled*` -Will be dynamically controlled by *enabled* unless manually specified -otherwise +Turns on/off the colorization. -## RED +## *Special variable* `*color-mode*` -Returns a string with the `red'string denotation preppended and the `reset' string denotation appended. +Controls the way `make-color-string` emits the color code. -*enabled* dynamically controls the function. +It should be one of the following keyword symbols: `:3bit`, `:8bit`, `:24bit`. +The specified color is converted to the nearest color in the color space. +The default value is `:8bit`. -## WHITE +Note that the actual appearance of the screen in the `:3bit` mode may be affected by +the terminal setting -- For example, many terminals do not use `FF0000` for the red. -Returns a string with the `white'string denotation preppended and the `reset' string denotation appended. +## *Constant* `+reset-color-string+` -*enabled* dynamically controls the function. +A constant string that resets the color state of the terminal. -## +RESET-COLOR-STRING+ -This string will reset ANSI colors +# Running test +Run `./testscr.ros` with Roswell. You can also manually run the test with +`(ql:quickload :cl-ansi-text.test) (fiveam:run! :cl-ansi-text)`. # Note Note that your terminal MUST be ANSI-compliant to show these -colors. My SLIME REPL (as of Feb 2013) does not display these -colors. I have to use a typical Linux/OSX terminal to see them. +colors. -This has been tested to work on a Linux system with SBCL, CLISP and -CCL. CCL may not work quite perfectly, some level of conniptions were -encountered in testing. The interested reader is advised to check the -MAKE-LOAD-FORM defmethod in cl-ansi-text.lisp. +SLIME REPL does not display these colors by default (2019.12.13). +To make it understand the ANSI escape sequence, +install `slime-repl-ansi-color` package available from [MELPA](https://melpa.org/) +using `package-install` and add the following in `.emacs`: + +``` lisp +(with-eval-after-load 'slime-repl + (require 'slime-repl-ansi-color)) +(add-hook 'slime-repl-mode-hook 'slime-repl-ansi-color-mode) +``` -An earlier variant was tested on OSX 10.6 with SBCL. +You can view the list of lisp implementation this library is tested +on [Travis-CI](https://travis-ci.org/pnathan/cl-ansi-text). +The testing environment is Linux, but we believe this should work also on OSX. License: LLGPL diff --git a/ci-test-run.sh b/ci-test-run.sh deleted file mode 100755 index 25e8107..0000000 --- a/ci-test-run.sh +++ /dev/null @@ -1,15 +0,0 @@ -#!/bin/bash -error=0 -if which sbcl; then - echo "CI run using SBCL" - sbcl --script run-tests.lisp - error=$? -fi - -if which lx86cl64; then - echo "CI run using CCL" - lx86cl64 -b --load run-tests.lisp - error=$(($error+$?)) -fi - -exit $error diff --git a/cl-ansi-text.asd b/cl-ansi-text.asd index a29781f..4e444aa 100644 --- a/cl-ansi-text.asd +++ b/cl-ansi-text.asd @@ -1,8 +1,11 @@ (asdf:defsystem #:cl-ansi-text - :depends-on ( #:cl-colors #:alexandria) - :components ((:file "cl-ansi-text")) + :depends-on ( #:cl-colors2 #:alexandria) + :serial t + :pathname "src/" + :components ((:file "cl-ansi-text") + (:file "define-colors")) :name "cl-ansi-text" - :version "1.0" + :version "1.1" :maintainer "Paul Nathan" :author "Paul Nathan" :licence "LLGPL" diff --git a/cl-ansi-text.lisp b/cl-ansi-text.lisp deleted file mode 100644 index 7cba11c..0000000 --- a/cl-ansi-text.lisp +++ /dev/null @@ -1,285 +0,0 @@ -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;; Paul Nathan 2013 -;;;; cl-ansi-text.lisp -;;;; -;;;; Portions of this code were written by taksatou under the -;;;; cl-rainbow name. -;;;; -;;;; A library to produce ANSI escape sequences. Particularly, -;;;; produces colorized text on terminals - -(defpackage :cl-ansi-text - (:use :common-lisp) - (:export - #:with-color - #:make-color-string - #:+reset-color-string+ - #:*enabled* - #:black - #:red - #:green - #:yellow - #:blue - #:magenta - #:cyan - #:white)) -(in-package :cl-ansi-text) - -;;; !!! NOTE TO CCL USERS !!! -;;; -;;; This seems to be *required* to make this compile in CCL. The -;;; reason is that CCL expects to be able to inline on compile, but -;;; structs don't set up that infrastructure by default. -;;; -;;; At least from the thread "Compiler problem, MCL 3.9" by Arthur -;;; Cater around '96. -#+ccl(common-lisp:eval-when (:compile-toplevel :load-toplevel :execute) - (defmethod make-load-form ((obj cl-colors:rgb ) &optional env) - (make-load-form-saving-slots obj))) - -(defparameter *enabled* t - "Turns on/off the colorization of functions") - -(defparameter +reset-color-string+ - (concatenate 'string (list (code-char 27) #\[ #\0 #\m)) - "This string will reset ANSI colors") - -(defvar +cl-colors+ - (vector - cl-colors:+black+ - cl-colors:+red+ - cl-colors:+green+ - cl-colors:+yellow+ - cl-colors:+blue+ - cl-colors:+magenta+ - cl-colors:+cyan+ - cl-colors:+white+) - "CL-COLORS colors") - -(eval-when (:compile-toplevel :load-toplevel :execute) - (defparameter +term-colors+ - (vector - :black - :red - :green - :yellow - :blue - :magenta - :cyan - :white) - "Basic colors")) - -(defparameter +text-style+ - '((:foreground . 30) - (:background . 40)) - "One or the other. Not an ANSI effect") - -(defparameter +term-effects+ - '((:unset . t) - (:reset . 0) - (:bright . 1) - (:italic . 3) - (:underline . 4) - (:blink . 5) - (:inverse . 7) - (:hide . 8) - (:normal . 22) - (:framed . 51) - (:encircled . 52) - (:overlined . 53) - (:not-framed-or-circled . 54) - (:not-overlined . 55)) - "ANSI terminal effects") - -(defun eq-colors (a b) - "Equality for cl-colors" - - ;; CL-COLORS LIB! - - ;; eql, equal doesn't quite work for compiled cl-colors on CCL - (and - (= (cl-colors:rgb-red a) - (cl-colors:rgb-red b)) - (= (cl-colors:rgb-green a) - (cl-colors:rgb-green b)) - (= (cl-colors:rgb-blue a) - (cl-colors:rgb-blue b)))) - -(defun cl-colors-to-ansi (color) - (position color +cl-colors+ :test #'eq-colors)) - -(defun term-colors-to-ansi (color) - (position color +term-colors+)) - - - -;; Find-X-code is the top-level interface for code-finding - -(defun find-color-code (color) - "Find the list denoting the color" - (typecase color - ;; Did we get a cl-color that we know about? - (cl-colors:rgb (cl-colors-to-ansi color)) - (symbol (term-colors-to-ansi color)))) - -(defun find-effect-code (effect) - "Returns the number for the text effect OR -t if no effect should be used OR -nil if the effect is unknown. - -effect should be a member of +term-effects+" - (cdr (assoc effect +term-effects+))) - -(defun find-style-code (style) - (cdr (assoc style +text-style+))) - -(defun rgb-code-p (color) - (typecase color - (list t) - (integer t))) - -(defun generate-control-string (code) - "General ANSI code" - (format nil "~c[~a" (code-char #o33) code)) - -(defun generate-color-string (code) - ;; m is the action character for color - (format nil "~am" (generate-control-string code))) - -(defun build-control-string (color - &optional - (effect :unset) - (style :foreground)) - "Color (cl-color or term-color) -Effect -Style" - (let ((effect-code (find-effect-code effect)) - (color-code (find-color-code color)) - (style-code (find-style-code style))) - - ;; Nil here indicates an error - (assert effect-code) - (assert style-code) - - ;; Returns a list for inspection; next layer turns it back into a - ;; string. - (concatenate - 'list - ;; We split between RGB and 32-color here; this preserves the - ;; interface without cluttering the 32-color code up. - ;; - (let ((codes nil)) - (unless (eq effect-code t) - (setf codes (cons effect-code codes))) - (if (rgb-code-p color) - (setf codes (cons (rgb-color-code color style) codes)) - (setf codes (cons (+ style-code color-code) codes))) - - (generate-color-string (format nil "~{~A~^;~}" codes)))))) - -;; Public callables. - -(defun make-color-string (color &key - (effect :unset) - (style :foreground) - ((enabled *enabled*) *enabled*)) - "Takes either a cl-color or a list denoting the ANSI colors and -returns a string sufficient to change to the given color. - -Will be dynamically controlled by *enabled* unless manually specified -otherwise" - (when *enabled* - (concatenate 'string - (build-control-string color effect style)))) - -(defmacro with-color ((color &key - (stream t) - (effect :unset) - (style :foreground)) - &body body) - "Writes out the string denoting a switch to `color`, executes body, -then writes out the string denoting a `reset`. - -*enabled* dynamically controls expansion.." - `(progn - (when *enabled* - (format ,stream "~a" (make-color-string ,color - :effect ,effect - :style ,style))) - (unwind-protect - (progn - ,@body) - (when *enabled* - (format ,stream "~a" +reset-color-string+))))) - -(defmacro gen-color-functions (color-names-vector) - `(progn - ,@(map 'list - (lambda (color) - `(defun ,(intern (symbol-name color)) (string &key - (effect :unset) - (style :foreground)) - ,(concatenate - 'string - "Returns a string with the `" (string-downcase color) - "'string denotation preppended and the `reset' string denotation appended. - -*enabled* dynamically controls the function." ) - (concatenate - 'string - (when *enabled* - (format nil "~a" (make-color-string ,color - :effect effect - :style style))) - string - (when *enabled* - (format nil "~a" +reset-color-string+))))) - color-names-vector))) - -(gen-color-functions #.(coerce +term-colors+ 'list)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; RGB color codes for some enhanced terminals - -;;; http://www.frexx.de/xterm-256-notes/ -(defun rgb-to-ansi (red green blue) - (let ((ansi-domain (mapcar #'(lambda (x) - (floor (* 6 (/ x 256.0)))) - (list red green blue)))) - (+ 16 - (* 36 (first ansi-domain)) - (* 6 (second ansi-domain)) - (third ansi-domain)))) - -(defun code-from-rgb (style red green blue) - (format nil "~d;5;~d" - (if (eql style :foreground) 38 48) - (rgb-to-ansi red green blue))) - - -(defgeneric rgb-color-code (color &optional style) - (:documentation - "Returns the 256-color code suitable for rendering on the Linux -extensions to xterm")) - -(defmethod rgb-color-code ((color list) &optional (style :foreground)) - (unless (consp color) - (error "~a must be a three-integer list" color)) - - (unless (and (integerp (first color)) - (integerp (second color)) - (integerp (second color))) - (error "~a must have three integers" color)) - - (code-from-rgb style - (first color) - (second color) - (third color))) - -(defmethod rgb-color-code ((color integer) &optional (style :foreground)) - ;; Takes RGB integer ala Web integers - (code-from-rgb style - ;; classic bitmask - (ash (logand color #xff0000) -16) - (ash (logand color #x00ff00) -8) - (logand color #x0000ff))) diff --git a/cl-ansi-text-test.asd b/cl-ansi-text.test.asd similarity index 67% rename from cl-ansi-text-test.asd rename to cl-ansi-text.test.asd index 73cee9c..0989a06 100644 --- a/cl-ansi-text-test.asd +++ b/cl-ansi-text.test.asd @@ -1,10 +1,10 @@ -(asdf:defsystem #:cl-ansi-text-test - :depends-on ( #:cl-colors #:alexandria #:cl-ansi-text #:fiveam) +(asdf:defsystem #:cl-ansi-text.test + :depends-on ( #:cl-colors2 #:alexandria #:cl-ansi-text #:fiveam) :components ((:module "test" :components ((:file "cl-ansi-text-test")))) :name "cl-ansi-text-test" - :version "1.0" + :version "1.1" :maintainer "Paul Nathan" :author "Paul Nathan" :licence "LLGPL" diff --git a/run-tests.lisp b/run-tests.lisp deleted file mode 100644 index f369b89..0000000 --- a/run-tests.lisp +++ /dev/null @@ -1,29 +0,0 @@ -#-quicklisp -(let ((quicklisp-init (merge-pathnames "quicklisp/setup.lisp" - (user-homedir-pathname)))) - (when (probe-file quicklisp-init) - (load quicklisp-init))) - -#+sbcl(require "sb-posix") - -(defparameter *pwd* - (concatenate 'string - (progn #+sbcl(sb-posix:getcwd) - #+ccl(ccl::current-directory-name)) - "/")) - -(push *pwd* asdf:*central-registry*) - - -(ql:quickload '(:cl-colors - :alexandria - :fiveam - - :cl-ansi-text - :cl-ansi-text-test)) - -(let ((result-status (cl-ansi-text-test::ci-run))) - (let ((posix-status - (if result-status 0 1))) - #+sbcl(sb-posix:exit posix-status) - #+ccl (quit posix-status))) diff --git a/src/cl-ansi-text.lisp b/src/cl-ansi-text.lisp new file mode 100644 index 0000000..418cc0e --- /dev/null +++ b/src/cl-ansi-text.lisp @@ -0,0 +1,254 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; Paul Nathan 2013 +;;;; cl-ansi-text.lisp +;;;; +;;;; Portions of this code were written by taksatou under the +;;;; cl-rainbow name. +;;;; +;;;; A library to produce ANSI escape sequences. Particularly, +;;;; produces colorized text on terminals + +(defpackage :cl-ansi-text + (:use :common-lisp) + (:export + #:color-specifier + #:with-color + #:make-color-string + #:+reset-color-string+ + #:*enabled* + #:black + #:red + #:green + #:yellow + #:blue + #:magenta + #:cyan + #:white + #:*color-mode* + #:color-string)) +(in-package :cl-ansi-text) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; constants + +(defvar *enabled* t + "Turns on/off the colorization.") + +(declaim (type (member :3bit :8bit :24bit) *color-mode*)) +(defvar *color-mode* :8bit + "Controls the way `make-color-string` emits the color code. + +It should be one of the following keyword symbols: `:3bit`, `:8bit`, `:24bit`. +The specified color is converted to the nearest color in the color space. + +Note that the actual appearance of the screen in the `:3bit` mode may be affected by +the terminal setting -- For example, many terminals do not use `FF0000` for the red.") + +(defvar +reset-color-string+ + (concatenate 'string (list (code-char 27) #\[ #\0 #\m)) + "A constant string that resets the color state of the terminal.") + +(defvar +cl-colors-basic-colors+ + (vector + cl-colors:+black+ + cl-colors:+red+ + cl-colors:+green+ + cl-colors:+yellow+ + cl-colors:+blue+ + cl-colors:+magenta+ + cl-colors:+cyan+ + cl-colors:+white+) + "CL-COLORS basic colors") + +(defvar +term-colors+ + (vector + :black + :red + :green + :yellow + :blue + :magenta + :cyan + :white) + "Basic colors") + +(defvar +text-style+ + '((:foreground . 30) + (:background . 40)) + "One or the other. Not an ANSI effect") + +(defvar +term-effects+ + '((:unset . t) + (:reset . 0) + (:bright . 1) + (:italic . 3) + (:underline . 4) + (:blink . 5) + (:inverse . 7) + (:hide . 8) + (:normal . 22) + (:framed . 51) + (:encircled . 52) + (:overlined . 53) + (:not-framed-or-circled . 54) + (:not-overlined . 55)) + "ANSI terminal effects") + +(defun color-string-p (string) + (every (lambda (c) + (member c '(#\# #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 + #\a #\b #\c #\d #\e #\f #\A #\B #\C #\D #\E #\F))) + string)) + +(deftype color-specifier () + `(or unsigned-byte + (cons (real 0 256) + (cons (real 0 256) + (cons (real 0 256) + nil))) + cl-colors:rgb + cl-colors:hsv + term-colors + color-string)) + +(deftype color-string () + `(and (or (string 3) + (string 4) + (string 6) + (string 7)) + (satisfies color-string-p))) + +(deftype term-colors () + `(member :black :red :green :yellow :blue :magenta :cyan :white)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun find-effect-code (effect) + "Returns the number for the text effect OR +t if no effect should be used OR +nil if the effect is unknown. + +effect should be a member of +term-effects+" + (cdr (assoc effect +term-effects+))) + +(defun find-style-code (style) + (cdr (assoc style +text-style+))) + +;; Public callables. + +(defun make-color-string (color &key + (effect :unset) + (style :foreground) + ((enabled *enabled*) *enabled*)) + "Takes an object of `color-specifier` and returns a string sufficient to change to the given color. + +Colorization is controlled by *enabled* unless manually specified otherwise by `:enabled` keyword." + (declare (type color-specifier color)) + (when *enabled* + (let ((effect-code (find-effect-code effect))) + ;; Nil here indicates an error + (assert effect-code) + (let ((codes nil)) + (unless (eq effect-code t) + (push effect-code codes)) + + ;; on 3bit, a list containing an integer in 30 - 37, 40 - 47. + ;; on 8bit, a list containing 5 and an integer. 38;5;n + ;; on 24bit, a list containing 2 and 3 more integers (r,g,b). 38;2;r;g;b + (setf codes (append (rgb-color-code color style) codes)) + (format nil "~c[~{~A~^;~}m" (code-char #o33) codes))))) + +(defmacro with-color ((color &key + (stream t) + (effect :unset) + (style :foreground)) + &body body) + "Writes out the ANSI escape code string +denoting `effect`, `style`, and a switch to `color`, then executes `body`, +then writes out the string that resets the decoration." + `(progn + (when *enabled* + (format ,stream "~a" (make-color-string ,color + :effect ,effect + :style ,style))) + (unwind-protect + (progn + ,@body) + (when *enabled* + (format ,stream "~a" +reset-color-string+))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; color handling + +(defgeneric rgb-color-code (color &optional style) + (:documentation + "Returns a list of codes suitable for the current color mode.")) + +(defmethod rgb-color-code ((color list) &optional (style :foreground)) + (assert (and (= 3 (length color)) + (every #'realp color) + (every (lambda (x) (<= 0 x 256)) color)) + nil "~a must be a list of numbers in [0,256]" color) + (rgb-color-code (apply #'cl-colors:rgb (mapcar (lambda (x) (/ x 256)) color)) + style)) + +(defmethod rgb-color-code ((color integer) &optional (style :foreground)) + "Takes RGB integer ala Web integers" + (rgb-color-code (cl-colors:rgb + ;; classic bitmask + (/ (ash (logand color #xff0000) -16) 256) + (/ (ash (logand color #x00ff00) -8) 256) + (/ (logand color #x0000ff) 256)) + style)) + +(defmethod rgb-color-code ((color string) &optional (style :foreground)) + "Takes RGB integer ala Web integers" + (rgb-color-code (cl-colors:hex-to-rgb color) + style)) + +(defmethod rgb-color-code ((color cl-colors:rgb) &optional (style :foreground)) + (code-from-rgb color style)) + +(defmethod rgb-color-code ((color cl-colors:hsv) &optional (style :foreground)) + (code-from-rgb (cl-colors:hsv-to-rgb color) style)) + +(defmethod rgb-color-code ((color symbol) &optional (style :foreground)) + (code-from-rgb (aref +cl-colors-basic-colors+ (position color +term-colors+)) style)) + +(defun code-from-rgb (color style) + (ecase *color-mode* + (:3bit + (list (+ (find-style-code style) ; 30 or 40 + ;; 0-7 + (rgb-to-ansi-3bit color)))) + (:8bit + (list (+ (find-style-code style) 8) ; 38 or 48 + 5 + (rgb-to-ansi-8bit color))) + (:24bit + (list (+ (find-style-code style) 8) + 2 + (ceiling (* 255 (cl-colors:rgb-red color))) + (ceiling (* 255 (cl-colors:rgb-green color))) + (ceiling (* 255 (cl-colors:rgb-blue color))))))) + +(defun rgb-to-ansi-3bit (color) + "find the closest color from +cl-colors-basic-colors+" + (labels ((square (x) + (* x x)) + (distance (color2) + (+ (square (- (cl-colors:rgb-red color) (cl-colors:rgb-red color2))) + (square (- (cl-colors:rgb-green color) (cl-colors:rgb-green color2))) + (square (- (cl-colors:rgb-blue color) (cl-colors:rgb-blue color2)))))) + (position (reduce (lambda (a b) + (if (< (distance a) (distance b)) + a b)) + +cl-colors-basic-colors+) + +cl-colors-basic-colors+))) + +(defun rgb-to-ansi-8bit (color) + "http://www.frexx.de/xterm-256-notes/" + (+ 16 + (* 36 (min 5 (floor (* 6 (cl-colors:rgb-red color))))) + (* 6 (min 5 (floor (* 6 (cl-colors:rgb-green color))))) + (* 1 (min 5 (floor (* 6 (cl-colors:rgb-blue color))))))) diff --git a/src/define-colors.lisp b/src/define-colors.lisp new file mode 100644 index 0000000..47b8ac2 --- /dev/null +++ b/src/define-colors.lisp @@ -0,0 +1,17 @@ + +(in-package :cl-ansi-text) + +(defmacro define-colors () + `(progn + ,@(map 'list + (lambda (color) + `(defun ,(intern (symbol-name color)) (string &key (effect :unset) (style :foreground)) + ,(format nil "Returns a string decorated in ~(~a~)." color) + (with-output-to-string (s) + (with-color (,color :stream s :effect effect :style style) + (write-string string s))))) + +term-colors+))) + +(define-colors) + + diff --git a/test/cl-ansi-text-test.lisp b/test/cl-ansi-text-test.lisp index 20cfc04..5ed2e29 100644 --- a/test/cl-ansi-text-test.lisp +++ b/test/cl-ansi-text-test.lisp @@ -8,61 +8,75 @@ :fiveam)) (in-package :cl-ansi-text-test) -(use-package :fiveam) -(use-package :cl-ansi-text) -(def-suite test-suite - :description "test suite.") +(def-suite :cl-ansi-text :description "test suite.") -(in-suite test-suite) +(in-suite :cl-ansi-text) +(defun make-color-string-as-list (&rest args) + (coerce (apply #'cl-ansi-text:make-color-string args) 'list)) (test basic-color-strings "Test the basic stuff" - (is (equal '(#\Esc #\[ #\3 #\1 #\m) - (cl-ansi-text::build-control-string :red :unset :foreground))) - (is (equal '(#\Esc #\[ #\4 #\1 #\m) - (cl-ansi-text::build-control-string :red :unset :background))) - (is (equal '(#\Esc #\[ #\4 #\2 #\; #\1 #\m) - (cl-ansi-text::build-control-string :green :bright :background)))) + (let ((*color-mode* :3bit)) + (is (equal '(#\Esc #\[ #\3 #\1 #\m) + (make-color-string-as-list :red :effect :unset :style :foreground))) + (is (equal '(#\Esc #\[ #\4 #\1 #\m) + (make-color-string-as-list :red :effect :unset :style :background))) + (is (equal '(#\Esc #\[ #\4 #\2 #\; #\1 #\m) + (make-color-string-as-list :green :effect :bright :style :background))))) (test enabled-connectivity "Test *enabled*'s capability" - (is (equal '(#\Esc #\[ #\3 #\1 #\m) - (let ((*enabled* t)) + (let ((*color-mode* :3bit)) + (is (equal '(#\Esc #\[ #\3 #\1 #\m) + (let ((*enabled* t)) + (make-color-string-as-list :red)))) + (is (equal '() + (let ((*enabled* nil)) + (make-color-string-as-list :red)))) + (is (equal "hi" + (let ((*enabled* nil)) + (with-output-to-string (s) + (with-color (:red :stream s) (format s "hi")))))) + (is (equal '(#\Esc #\[ #\3 #\1 #\m #\T #\e #\s #\t #\! #\Esc #\[ #\0 #\m) (concatenate 'list - (cl-ansi-text:make-color-string :red))))) - (is (equal '() - (let ((*enabled* nil)) - (concatenate - 'list - (cl-ansi-text:make-color-string :red))))) - (is (equal "hi" - (let ((*enabled* nil)) - (with-output-to-string (s) - (with-color (:red :stream s) (format s "hi")))))) - (is (equal '(#\Esc #\[ #\3 #\1 #\m #\T #\e #\s #\t #\! #\Esc #\[ #\0 #\m) - (concatenate - 'list - (with-output-to-string (s) - (with-color (:red :stream s) - (format s "Test!"))))))) + (with-output-to-string (s) + (with-color (:red :stream s) + (format s "Test!")))))))) (test rgb-suite "Test RGB colors" - (is (equal '(#\Esc #\[ #\3 #\8 #\; #\5 #\; #\2 #\1 #\4 #\m) - (cl-ansi-text::build-control-string #xFFAA00 - :unset :foreground))) - (is (equal '(#\Esc #\[ #\4 #\8 #\; #\5 #\; #\2 #\1 #\4 #\m) - (cl-ansi-text::build-control-string #xFFAA00 - :unset :background))) - (is (equal '(#\Esc #\[ #\4 #\8 #\; #\5 #\; #\1 #\6 #\m) - (cl-ansi-text::build-control-string #x000000 - :unset :background))) - (is (equal '(#\Esc #\[ #\4 #\8 #\; #\5 #\; #\2 #\3 #\1 #\m) - (cl-ansi-text::build-control-string #xFFFFFF - :unset :background)))) + (let ((*color-mode* :3bit)) + (is (equal '(#\Esc #\[ #\3 #\1 #\m) + (make-color-string-as-list #xFF0000 :effect :unset :style :foreground))) + (is (equal '(#\Esc #\[ #\4 #\2 #\m) + (make-color-string-as-list #x00FF00 :effect :unset :style :background))) + (is (equal '(#\Esc #\[ #\4 #\4 #\m) + (make-color-string-as-list #x0000FF :effect :unset :style :background))) + (is (equal '(#\Esc #\[ #\4 #\0 #\m) + (make-color-string-as-list #x000000 :effect :unset :style :background))) + (is (equal '(#\Esc #\[ #\4 #\7 #\m) + (make-color-string-as-list #xFFFFFF :effect :unset :style :background)))) + (let ((*color-mode* :8bit)) + (is (equal '(#\Esc #\[ #\3 #\8 #\; #\5 #\; #\2 #\1 #\4 #\m) + (make-color-string-as-list #xFFAA00 :effect :unset :style :foreground))) + (is (equal '(#\Esc #\[ #\4 #\8 #\; #\5 #\; #\2 #\1 #\4 #\m) + (make-color-string-as-list #xFFAA00 :effect :unset :style :background))) + (is (equal '(#\Esc #\[ #\4 #\8 #\; #\5 #\; #\1 #\6 #\m) + (make-color-string-as-list #x000000 :effect :unset :style :background))) + (is (equal '(#\Esc #\[ #\4 #\8 #\; #\5 #\; #\2 #\3 #\1 #\m) + (make-color-string-as-list #xFFFFFF :effect :unset :style :background)))) + (let ((*color-mode* :24bit)) + (is (equal '(#\Esc #\[ #\3 #\8 #\; #\2 #\; #\2 #\5 #\5 #\; #\1 #\7 #\0 #\; #\0 #\m) + (make-color-string-as-list #xFFAA00 :effect :unset :style :foreground))) + (is (equal '(#\Esc #\[ #\4 #\8 #\; #\2 #\; #\2 #\5 #\5 #\; #\1 #\7 #\0 #\; #\0 #\m) + (make-color-string-as-list #xFFAA00 :effect :unset :style :background))) + (is (equal '(#\Esc #\[ #\4 #\8 #\; #\2 #\; #\0 #\; #\0 #\; #\0 #\m) + (make-color-string-as-list #x000000 :effect :unset :style :background))) + (is (equal '(#\Esc #\[ #\4 #\8 #\; #\2 #\; #\2 #\5 #\5 #\; #\2 #\5 #\5 #\; #\2 #\5 #\5 #\m) + (make-color-string-as-list #xFFFFFF :effect :unset :style :background))))) (test color-named-functions (let ((str "Test string.")) @@ -108,16 +122,3 @@ (equal str (white (cyan (magenta (blue (yellow (green (red (black str)))))))))))) -(defun run-tests () - (let ((results (run 'test-suite))) - (explain! results) - (if (position-if #'(lambda (e) - (eq (type-of e) - 'IT.BESE.FIVEAM::TEST-FAILURE - )) - results) - nil - t))) - -(defun ci-run () - (run-tests)) diff --git a/testscr.ros b/testscr.ros new file mode 100755 index 0000000..ba3d136 --- /dev/null +++ b/testscr.ros @@ -0,0 +1,18 @@ +#!/bin/sh +#|-*- mode:lisp -*-|# +#| +exec ros -Q -- $0 "$@" +|# + +(ql:quickload :fiveam) + +(defun main (&rest argv) + (declare (ignorable argv)) + (uiop:quit (if (handler-case + (progn + (ql:quickload :cl-ansi-text.test) + (5am:run! :cl-ansi-text)) + (serious-condition (c) + (describe c) + (uiop:quit 2))) + 0 1)))