r7rs-tests/snow/chibi/term/ansi.scm

525 lines
19 KiB
Scheme

;; 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.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (make-simple-escape-procedure parameter)
(let ((code (string-append "\x1B;[" (number->string parameter) "m")))
(lambda () code)))
(define (make-wrap-procedure start-escape end-escape)
(lambda (str)
(if (not (string? str))
(error "argument must be a string" str))
(if (ansi-escapes-enabled?)
(string-append start-escape str end-escape)
str)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Some definitions are wrapped in begin in order to avoid Scribble
;; generating duplicate signatures.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;> \section{Library}
(define black-escape
(make-simple-escape-procedure 30))
(define red-escape
(make-simple-escape-procedure 31))
(define green-escape
(make-simple-escape-procedure 32))
(define yellow-escape
(make-simple-escape-procedure 33))
(define blue-escape
(make-simple-escape-procedure 34))
(define magenta-escape
(make-simple-escape-procedure 35))
(define cyan-escape
(make-simple-escape-procedure 36))
(define white-escape
(make-simple-escape-procedure 37))
;;> Return a string consisting of an ANSI escape code to select the
;;> specified text color.
;;/
;;> Return a string consisting of an ANSI escape code to select the
;;> text color specified by the \var{red-level}, \var{green-level},
;;> and \var{blue-level} arguments, each of which must be an exact
;;> integer in the range [0, 5].
;;>
;;> The caller is resonsible for verifying that the terminal supports
;;> 256 colors.
(define (rgb-escape red-level green-level blue-level)
(when (not (and (exact-integer? red-level) (<= 0 red-level 5)))
(error "invalid red-level value" red-level))
(when (not (and (exact-integer? green-level) (<= 0 green-level 5)))
(error "invalid green-level value" green-level))
(when (not (and (exact-integer? blue-level) (<= 0 blue-level 5)))
(error "invalid blue-level value" blue-level))
(string-append
"\x1B;[38;5;"
(number->string (+ (* 36 red-level) (* 6 green-level) blue-level 16))
"m"))
;;> Return a string consisting of an ANSI escape code to select the
;;> text color specified by the \var{gray-level} argument, which must
;;> be an exact integer in the range [0, 23].
;;>
;;> The caller is resonsible for verifying that the terminal supports
;;> 256 colors.
(define (gray-escape gray-level)
(when (not (and (exact-integer? gray-level) (<= 0 gray-level 23)))
(error "invalid gray-level value" gray-level))
(string-append "\x1B;[38;5;"
(number->string (+ gray-level 232))
"m"))
;;> The true-color equivalent of \scheme{rgb-escape}. Return a string
;;> consisting of an ANSI escape code to select the text color
;;> specified by the \var{red-level}, \var{green-level}, and
;;> \var{blue-level} arguments, each of which must be an exact integer
;;> in the range [0, 255].
(define (rgb24-escape red-level green-level blue-level)
(when (not (and (exact-integer? red-level) (<= 0 red-level 255)))
(error "invalid red-level value" red-level))
(when (not (and (exact-integer? green-level) (<= 0 green-level 255)))
(error "invalid green-level value" green-level))
(when (not (and (exact-integer? blue-level) (<= 0 blue-level 255)))
(error "invalid blue-level value" blue-level))
(string-append
"\x1B;[38;2;"
(number->string red-level) ";"
(number->string green-level) ";"
(number->string blue-level)
"m"))
;;> Return a string consisting of an ANSI escape code to select the
;;> default text color.
(define reset-color-escape
(make-simple-escape-procedure 39))
(define black
(make-wrap-procedure (black-escape)
(reset-color-escape)))
(define red
(make-wrap-procedure (red-escape)
(reset-color-escape)))
(define green
(make-wrap-procedure (green-escape)
(reset-color-escape)))
(define yellow
(make-wrap-procedure (yellow-escape)
(reset-color-escape)))
(define blue
(make-wrap-procedure (blue-escape)
(reset-color-escape)))
(define magenta
(make-wrap-procedure (magenta-escape)
(reset-color-escape)))
(define cyan
(make-wrap-procedure (cyan-escape)
(reset-color-escape)))
(define white
(make-wrap-procedure (white-escape)
(reset-color-escape)))
;;> 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}.
;;/
;;> Returns a procedure which takes a single argument, a string, and
;;> which when called behaves as follows.
;;>
;;> If ANSI escapes are enabled, the procedure returns a string
;;> consisting of its argument with a prefix that selects specified
;;> text color (obtained by calling the \scheme{rgb-escape} procedure
;;> with the values of the \var{red-level}, \var{green-level}, and
;;> \var{blue-level} arguments) and a suffix that selects the default
;;> text color.
;;>
;;> If ANSI escapes are not enabled, the procedure returns its argument.
;;>
;;> The caller is resonsible for verifying that the terminal supports
;;> 256 colors.
(define (rgb red-level green-level blue-level)
(make-wrap-procedure (rgb-escape red-level green-level blue-level)
(reset-color-escape)))
;;> Returns a procedure which takes a single argument, a string, and
;;> which when called behaves as follows.
;;>
;;> If ANSI escapes are enabled, the procedure returns a string
;;> consisting of its argument with a prefix that selects specified
;;> text color (obtained by calling the \scheme{gray-escape} procedure
;;> with the values of the \var{gray-level} argument) and a suffix
;;> that selects the default text color.
;;>
;;> If ANSI escapes are not enabled, the procedure returns its argument.
;;>
;;> The caller is resonsible for verifying that the terminal supports
;;> 256 colors.
(define (gray gray-level)
(make-wrap-procedure (gray-escape gray-level)
(reset-color-escape)))
;;> The true-color equivalent of \scheme{rbg}, extending the ranges
;;> to [0, 255].
(define (rgb24 red-level green-level blue-level)
(make-wrap-procedure (rgb24-escape red-level green-level blue-level)
(reset-color-escape)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define black-background-escape
(make-simple-escape-procedure 40))
(define red-background-escape
(make-simple-escape-procedure 41))
(define green-background-escape
(make-simple-escape-procedure 42))
(define yellow-background-escape
(make-simple-escape-procedure 43))
(define blue-background-escape
(make-simple-escape-procedure 44))
(define magenta-background-escape
(make-simple-escape-procedure 45))
(define cyan-background-escape
(make-simple-escape-procedure 46))
(define white-background-escape
(make-simple-escape-procedure 47))
;;> Return a string consisting of an ANSI escape code to select the
;;> specified background color.
;;/
;;> Return a string consisting of an ANSI escape code to select the
;;> background color specified by the \var{red-level}, \var{green-level},
;;> and \var{blue-level} arguments, each of which must be an exact
;;> integer in the range [0, 5].
;;>
;;> The caller is resonsible for verifying that the terminal supports
;;> 256 colors.
(define (rgb-background-escape red-level green-level blue-level)
(when (not (and (exact-integer? red-level) (<= 0 red-level 5)))
(error "invalid red-level value" red-level))
(when (not (and (exact-integer? green-level) (<= 0 green-level 5)))
(error "invalid green-level value" green-level))
(when (not (and (exact-integer? blue-level) (<= 0 blue-level 5)))
(error "invalid blue-level value" blue-level))
(string-append
"\x1B;[48;5;"
(number->string (+ (* 36 red-level) (* 6 green-level) blue-level 16))
"m"))
;;> Return a string consisting of an ANSI escape code to select the
;;> background color specified by the \var{gray-level} argument, which
;;> must be an exact integer in the range [0, 23].
;;>
;;> The caller is resonsible for verifying that the terminal supports
;;> 256 colors.
(define (gray-background-escape gray-level)
(when (not (and (exact-integer? gray-level) (<= 0 gray-level 23)))
(error "invalid gray-level value" gray-level))
(string-append "\x1B;[48;5;"
(number->string (+ gray-level 232))
"m"))
;;> The true-color equivalent of \scheme{rgb-background-escape}.
;;> Return a string consisting of an ANSI escape code to select the
;;> text color specified by the \var{red-level}, \var{green-level},
;;> and \var{blue-level} arguments, each of which must be an exact
;;> integer in the range [0, 255].
(define (rgb24-background-escape red-level green-level blue-level)
(when (not (and (exact-integer? red-level) (<= 0 red-level 255)))
(error "invalid red-level value" red-level))
(when (not (and (exact-integer? green-level) (<= 0 green-level 255)))
(error "invalid green-level value" green-level))
(when (not (and (exact-integer? blue-level) (<= 0 blue-level 255)))
(error "invalid blue-level value" blue-level))
(string-append
"\x1B;[48;5;"
(number->string red-level) ";"
(number->string green-level) ";"
(number->string blue-level)
"m"))
;;> \procedure{(reset-background-color-escape)}
;;>
;;> Return a string consisting of an ANSI escape code to select the
;;> default background color.
(define reset-background-color-escape
(make-simple-escape-procedure 49))
(define black-background
(make-wrap-procedure (black-background-escape)
(reset-background-color-escape)))
(define red-background
(make-wrap-procedure (red-background-escape)
(reset-background-color-escape)))
(define green-background
(make-wrap-procedure (green-background-escape)
(reset-background-color-escape)))
(define yellow-background
(make-wrap-procedure (yellow-background-escape)
(reset-background-color-escape)))
(define blue-background
(make-wrap-procedure (blue-background-escape)
(reset-background-color-escape)))
(define magenta-background
(make-wrap-procedure (magenta-background-escape)
(reset-background-color-escape)))
(define cyan-background
(make-wrap-procedure (cyan-background-escape)
(reset-background-color-escape)))
(define white-background
(make-wrap-procedure (white-background-escape)
(reset-background-color-escape)))
;;> 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}.
;;/
;;> Returns a procedure which takes a single argument, a string, and
;;> which when called behaves as follows.
;;>
;;> If ANSI escapes are enabled, the procedure returns a string
;;> consisting of its argument with a prefix that selects specified
;;> background color (obtained by calling the \scheme{rgb-background-escape}
;;> procedure with the values of the \var{red-level}, \var{green-level},
;;> and \var{blue-level} arguments) and a suffix that selects the
;;> default background color.
;;>
;;> If ANSI escapes are not enabled, the procedure returns its argument.
;;>
;;> The caller is resonsible for verifying that the terminal supports
;;> 256 colors.
(define (rgb-background red-level green-level blue-level)
(make-wrap-procedure (rgb-background-escape red-level green-level blue-level)
(reset-background-color-escape)))
;;> Returns a procedure which takes a single argument, a string, and
;;> which when called behaves as follows.
;;>
;;> If ANSI escapes are enabled, the procedure returns a string
;;> consisting of its argument with a prefix that selects specified
;;> background color (obtained by calling the \scheme{gray-background-escape}
;;> procedure with the values of the \var{gray-level} argument) and a
;;> suffix that selects the default background color.
;;>
;;> If ANSI escapes are not enabled, the procedure returns its argument.
;;>
;;> The caller is resonsible for verifying that the terminal supports
;;> 256 colors.
(define (gray-background gray-level)
(make-wrap-procedure (gray-background-escape gray-level)
(reset-background-color-escape)))
;;> The true-color equivalent of \scheme{rbg-background}, extending
;;> the ranges to [0, 255].
(define (rgb24-background red-level green-level blue-level)
(make-wrap-procedure
(rgb24-background-escape red-level green-level blue-level)
(reset-background-color-escape)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;> Return a string consisting of an ANSI escape code to select bold
;;> style.
(define bold-escape
(make-simple-escape-procedure 1))
;;> Return a string consisting of an ANSI escape code to select non-bold
;;> style.
(define reset-bold-escape
(make-simple-escape-procedure 22))
;;> 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 (make-wrap-procedure (bold-escape)
(reset-bold-escape)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;> Return a string consisting of an ANSI escape code to select
;;> underlined style.
(define underline-escape
(make-simple-escape-procedure 4))
;;> Return a string consisting of an ANSI escape code to select
;;> non-underlined style.
(define reset-underline-escape
(make-simple-escape-procedure 24))
;;> 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
(make-wrap-procedure (underline-escape) (reset-underline-escape)))
;;> Return a string consisting of an ANSI escape code to select
;;> italic style.
(define italic-escape
(make-simple-escape-procedure 3))
;;> Return a string consisting of an ANSI escape code to select
;;> non-italic style.
(define reset-italic-escape
(make-simple-escape-procedure 23))
;;> Returns \var{str} optionally wrapped in italic escapes.
(define italic
(make-wrap-procedure (italic-escape) (reset-italic-escape)))
;;> Return a string consisting of an ANSI escape code to select
;;> strikethrough style.
(define strikethrough-escape
(make-simple-escape-procedure 9))
;;> Return a string consisting of an ANSI escape code to select
;;> non-strikethrough style.
(define reset-strikethrough-escape
(make-simple-escape-procedure 29))
;;> Returns \var{str} optionally wrapped in strikethrough escapes.
(define strikethrough
(make-wrap-procedure (strikethrough-escape) (reset-strikethrough-escape)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;> Return a string consisting of an ANSI escape code to select negative
;;> style (text in the background color and background in the text
;;> color).
(define negative-escape
(make-simple-escape-procedure 7))
;;> Return a string consisting of an ANSI escape code to select positive
;;> style (text in the text color and background in the background
;;> color).
(define reset-negative-escape
(make-simple-escape-procedure 27))
;;> 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 (text in the text color and
;;> background in the background color).
;;>
;;> If ANSI escapes are not enabled, return \var{str}.
(define negative (make-wrap-procedure (negative-escape)
(reset-negative-escape)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;> A parameter object that determines whether ANSI escapes are enabled
;;> in some of 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{"rxvt-unicode-256color"}, \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"
"tmux-256color" "rxvt-unicode-256color"))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;> \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"))))}
;;>