thin-provisioning-tools/functional-tests/fmt/fmt-color.scm
Joe Thornber 3e5de399a7 [functional tests] Remove dependency on the ThunderChez library.
I've just moved the relevant code into the functional-tests dir.
2020-04-30 12:07:42 +01:00

78 lines
2.9 KiB
Scheme

;;;; fmt-color.scm -- colored output
;;
;; Copyright (c) 2006-2007 Alex Shinn. All rights reserved.
;; BSD-style license: http://synthcode.com/license.txt
(define (fmt-color st) (fmt-ref st 'color))
(define (fmt-in-html? st) (fmt-ref st 'in-html?))
(define (fmt-use-html-font? st) (fmt-ref st 'use-html-font?))
(define (color->ansi x)
(if (number? x)
(let ((r (arithmetic-shift x -16))
(g (bitwise-and (arithmetic-shift x -8) #xFF))
(b (bitwise-and x #xFF)))
;; just picks the highest color value - need to detect blends
(color->ansi
(cond
((> r g) (if (> r b) 'red 'blue))
((> g b) 'green)
(else 'blue))))
(case x
((bold) "1")
((dark) "2")
((underline) "4")
((black) "30")
((red) "31")
((green) "32")
((yellow) "33")
((blue) "34")
((magenta) "35")
((cyan) "36")
((white) "37")
(else "0"))))
(define (ansi-escape color)
(cat (integer->char 27) "[" (color->ansi color) "m"))
(define (fmt-in-html . args)
(fmt-let 'in-html? #t (apply-cat args)))
(define (fmt-colored color . args)
(fmt-if fmt-in-html?
(cond
((eq? color 'bold)
(cat "<b>" (apply-cat args) "</b>"))
((eq? color 'underline)
(cat "<u>" (apply-cat args) "</u>"))
(else
(let ((cname (if (number? color) (cat "#" color) color)))
(fmt-if fmt-use-html-font?
(cat "<font color=\"" cname "\">" (apply-cat args)
"</font>")
(cat "<span style=color:\"" cname "\">"
(apply-cat args) "</span>")))))
(lambda (st)
(let ((old-color (fmt-color st)))
((fmt-let 'color color
(cat (ansi-escape color)
(apply-cat args)
(if (or (memv color '(bold underline))
(memv old-color '(bold underline)))
(ansi-escape 'reset)
(lambda (st) st))
(ansi-escape old-color)))
st)))))
(define (fmt-red . args) (fmt-colored 'red (apply-cat args)))
(define (fmt-blue . args) (fmt-colored 'blue (apply-cat args)))
(define (fmt-green . args) (fmt-colored 'green (apply-cat args)))
(define (fmt-cyan . args) (fmt-colored 'cyan (apply-cat args)))
(define (fmt-yellow . args) (fmt-colored 'yellow (apply-cat args)))
(define (fmt-magenta . args) (fmt-colored 'magenta (apply-cat args)))
(define (fmt-white . args) (fmt-colored 'white (apply-cat args)))
(define (fmt-black . args) (fmt-colored 'black (apply-cat args)))
(define (fmt-bold . args) (fmt-colored 'bold (apply-cat args)))
(define (fmt-underline . args) (fmt-colored 'underline (apply-cat args)))