78 lines
2.9 KiB
Scheme
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)))
|
||
|
|
|