diff --git a/lib/chibi/term/ansi.scm b/lib/chibi/term/ansi.scm new file mode 100644 index 00000000..2b8b81a3 --- /dev/null +++ b/lib/chibi/term/ansi.scm @@ -0,0 +1,185 @@ +;; Copyright (c) 2010-2014 Alex Shinn. All rights reserved. BSD-style +;; license: http://synthcode.com/license.txt + +;;> A library to use ANSI escape codes to format text and background +;;> color, font weigh, and underlining. + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; Code to bracket string str with ANSI escape codes to set the select +;; graphic rendition (SGR) parameters first to start-code and then to +;; end-code. This is a macro rather than, say, a procedure returning a +;; procedure to allow us to write the procedure definitions below such +;; that they are recognised by scribble. + +(define-syntax bracket-with-sgr-parameters-body + (syntax-rules () + ((bracket-with-sgr-parameters-body start-code str end-code) + (begin + (if (not (string? str)) + (error "argument must be a string" str)) + (if (ansi-escapes-enabled?) + (string-append "\x1B;[" (number->string start-code) "m" + str + "\x1B;[" (number->string end-code) "m") + str))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (black str) + (bracket-with-sgr-parameters-body 30 str 39)) + +(define (red str) + (bracket-with-sgr-parameters-body 31 str 39)) + +(define (green str) + (bracket-with-sgr-parameters-body 32 str 39)) + +(define (yellow str) + (bracket-with-sgr-parameters-body 33 str 39)) + +(define (blue str) + (bracket-with-sgr-parameters-body 34 str 39)) + +(define (magenta str) + (bracket-with-sgr-parameters-body 35 str 39)) + +(define (cyan str) + (bracket-with-sgr-parameters-body 36 str 39)) + +(define (white str) + (bracket-with-sgr-parameters-body 37 str 39)) + +;;> If ANSI escapes are enabled, return a string consisting of the +;;> string \var{str} with a prefix that selects specified text color +;;> and a suffix that selects the default text color. +;;> +;;/ If ANSI escapes are not enabled, return \var{str}. + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (background-black str) + (bracket-with-sgr-parameters-body 40 str 49)) + +(define (background-red str) + (bracket-with-sgr-parameters-body 41 str 49)) + +(define (background-green str) + (bracket-with-sgr-parameters-body 42 str 49)) + +(define (background-yellow str) + (bracket-with-sgr-parameters-body 43 str 49)) + +(define (background-blue str) + (bracket-with-sgr-parameters-body 44 str 49)) + +(define (background-magenta str) + (bracket-with-sgr-parameters-body 45 str 49)) + +(define (background-cyan str) + (bracket-with-sgr-parameters-body 46 str 49)) + +(define (background-white str) + (bracket-with-sgr-parameters-body 47 str 49)) + +;;> If ANSI escapes are enabled, return a string consisting of the +;;> string \var{str} with a prefix that selects specified background +;;> color and a suffix that selects the default background color. +;;> +;;/ If ANSI escapes are not enabled, return \var{str}. + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;> If ANSI escapes are enabled, return a string consisting of the +;;> string \var{str} with a prefix that selects bold style +;;> and a suffix that selects non-bold style. +;;> +;;> If ANSI escapes are not enabled, return \var{str}. + +(define (bold str) + (bracket-with-sgr-parameters-body 1 str 22)) + +;;> If ANSI escapes are enabled, return a string consisting of the +;;> string \var{str} with a prefix that selects underlined +;;> style and a suffix that selects non-underlined style. +;;> +;;> If ANSI escapes are not enabled, return \var{str}. + +(define (underline str) + (bracket-with-sgr-parameters-body 4 str 24)) + +;;> If ANSI escapes are enabled, return a string consisting of the +;;> string \var{str} with a prefix that selects negative style (text in the background color and background in the text color) +;;> and a suffix that selects positive style. +;;> +;;> If ANSI escapes are not enabled, return \var{str}. + +(define (negative str) + (bracket-with-sgr-parameters-body 7 str 27)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;> A parameter object that determines whether ANSI escapes are enabled +;;> in the preceding procedures. They are disabled if \scheme{(ansi-escapes-enabled?)} +;;> returns \scheme{#f}, and otherwise they are enabled. +;;> +;;> The initial value returned by \scheme{(ansi-escapes-enabled?)} is determined by the +;;> environment. +;;> +;;> If the environment variable \scheme{ANSI_ESCAPES_ENABLED} is set, +;;> its value determines the initial value returned by +;;> \scheme{(ansi-escapes-enabled?)}. If the value of +;;> \scheme{ANSI_ESCAPES_ENABLED} is \scheme{"0"}, the initial value +;;> is \scheme{#f}, otherwise the initial value is \scheme{#t}. +;;> +;;> If the environment variable \scheme{ANSI_ESCAPES_ENABLED} is not +;;> set, but the environment variable \scheme{TERM} is set, the value +;;> of the latter determines the initial value returned by +;;> \scheme{(ansi-escapes-enabled?)}. If the value of \scheme{TERM} is +;;> \scheme{"xterm"}, \scheme{"xterm-color"}, \scheme{"xterm-256color"}, +;;> \scheme{"rxvt"}, \scheme{"kterm"}, \scheme{"linux"}, \scheme{"screen"}, +;;> \scheme{"screen-256color"}, or \scheme{"vt100"}, the initial value +;;> is \scheme{#t}, otherwise the initial value is \scheme{#f}. +;;> +;;> If neither of the environment variables \scheme{ANSI_ESCAPES_ENABLED} +;;> and \scheme{TERM} are set, the initial value returned by +;;> \scheme{(ansi-escapes-enabled?)} is \scheme{#f}. + +(define ansi-escapes-enabled? + (make-parameter + (cond + ((get-environment-variable "ANSI_ESCAPES_ENABLED") + => (lambda (s) (not (equal? s "0")))) + (else + (member (get-environment-variable "TERM") + '("xterm" "xterm-color" "xterm-256color" "rxvt" "kterm" + "linux" "screen" "screen-256color" "vt100")))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;> \section{Notes} +;;> +;;> It is important to remember that the formatting procedures apply +;;> a prefix to set a particular graphics parameter and a suffix to +;;> reset the parameter to its default value. This can lead to surprises. +;;> For example, on an ANSI terminal, one might mistakenly expect the +;;> following to display GREEN in green text and then RED in red text: +;;> +;;> \codeblock{(display (red (string-append (green "GREEN") "RED")))} +;;> +;;> However, it will actually display GREEN in green text and then RED +;;> in the default text color. This is a limitation of ANSI control +;;> codes; graphics attributes are not saved to and restored from a +;;> stack, but instead are simply set. One way to display GREEN in +;;> green text and then RED in red text is: +;;> +;;> \codeblock{(display (string-append (green "GREEN") (red "RED")))} +;;> +;;> On the other hand, text color, background color, font weight (bold +;;> or default), underline (on or off), image (positive or negative) +;;> are orthogonal. So, for example, on an ANSI terminal the following +;;> should display GREEN in green text and then RED in red text, with +;;> both in bold and GREEN underlined. +;;> +;;> \codeblock{(display (bold (string-append (underline (green "GREEN")) (red "RED"))))} +;;> diff --git a/lib/chibi/term/ansi.sld b/lib/chibi/term/ansi.sld new file mode 100644 index 00000000..4b7dd0ae --- /dev/null +++ b/lib/chibi/term/ansi.sld @@ -0,0 +1,14 @@ +(define-library (chibi term ansi) + (export + black red yellow green + blue cyan magenta white + background-black background-red background-yellow background-green + background-blue background-cyan background-magenta background-white + bold + underline + negative + ansi-escapes-enabled?) + (import (scheme base) + (scheme write) + (scheme process-context)) + (include "ansi.scm")) diff --git a/tests/lib-tests.scm b/tests/lib-tests.scm index c7971048..1f1d3a1f 100644 --- a/tests/lib-tests.scm +++ b/tests/lib-tests.scm @@ -26,6 +26,7 @@ (load "tests/sha-tests.scm") ;; (load "tests/rsa-tests.scm") (load "tests/tar-tests.scm") +(load "tests/term-ansi-tests.scm") (cond-expand (full-unicode (load "tests/unicode-tests.scm")) (else #f)) (cond-expand diff --git a/tests/term-ansi-tests.scm b/tests/term-ansi-tests.scm new file mode 100644 index 00000000..f7b11f7a --- /dev/null +++ b/tests/term-ansi-tests.scm @@ -0,0 +1,52 @@ +(import (chibi) + (only (scheme base) parameterize) + (chibi test) + (chibi term ansi)) + +(test-begin "term.ansi") + +(test-assert (procedure? ansi-escapes-enabled?)) +(test-assert + (let ((tag (cons #t #t))) + (eqv? tag + (parameterize ((ansi-escapes-enabled? tag)) + (ansi-escapes-enabled?))))) + +(define-syntax test-term-ansi + (syntax-rules () + ((test-term-ansi p s) + (begin + (test-assert (procedure? p)) + (test-error (p)) + (test-error (p #f)) + (test-error (p "" #f)) + (test (p "FOO") + "FOO" + (parameterize ((ansi-escapes-enabled? #f)) (p "FOO"))) + (test (p "FOO") + s + (parameterize ((ansi-escapes-enabled? #t)) (p "FOO"))))))) + +(test-term-ansi black "\x1b;[30mFOO\x1b;[39m") +(test-term-ansi red "\x1b;[31mFOO\x1b;[39m") +(test-term-ansi yellow "\x1b;[33mFOO\x1b;[39m") +(test-term-ansi green "\x1b;[32mFOO\x1b;[39m") +(test-term-ansi blue "\x1b;[34mFOO\x1b;[39m") +(test-term-ansi cyan "\x1b;[36mFOO\x1b;[39m") +(test-term-ansi magenta "\x1b;[35mFOO\x1b;[39m") +(test-term-ansi white "\x1b;[37mFOO\x1b;[39m") + +(test-term-ansi background-black "\x1b;[40mFOO\x1b;[49m") +(test-term-ansi background-red "\x1b;[41mFOO\x1b;[49m") +(test-term-ansi background-yellow "\x1b;[43mFOO\x1b;[49m") +(test-term-ansi background-green "\x1b;[42mFOO\x1b;[49m") +(test-term-ansi background-blue "\x1b;[44mFOO\x1b;[49m") +(test-term-ansi background-cyan "\x1b;[46mFOO\x1b;[49m") +(test-term-ansi background-magenta "\x1b;[45mFOO\x1b;[49m") +(test-term-ansi background-white "\x1b;[47mFOO\x1b;[49m") + +(test-term-ansi bold "\x1b;[1mFOO\x1b;[22m") +(test-term-ansi underline "\x1b;[4mFOO\x1b;[24m") +(test-term-ansi negative "\x1b;[7mFOO\x1b;[27m") + +(test-end)