source: project/release/3/fmt/fmt-color.scm @ 10190

Last change on this file since 10190 was 10190, checked in by Alex Shinn, 12 years ago

Updating to version 0.513.

File size: 2.9 KB
Line 
1;;;; fmt-color.scm -- colored output
2;;
3;; Copyright (c) 2006-2007 Alex Shinn.  All rights reserved.
4;; BSD-style license: http://synthcode.com/license.txt
5
6(define (fmt-color st) (fmt-ref st 'color))
7(define (fmt-in-html? st) (fmt-ref st 'in-html?))
8(define (fmt-use-html-font? st) (fmt-ref st 'use-html-font?))
9
10(define (color->ansi x)
11  (if (number? x)
12      (let ((r (arithmetic-shift x -16))
13            (g (bitwise-and (arithmetic-shift x -8) #xFF))
14            (b (bitwise-and x #xFF)))
15        ;; just picks the highest color value - need to detect blends
16        (color->ansi
17         (cond
18           ((> r g) (if (> r b) 'red 'blue))
19           ((> g b) 'green)
20           (else 'blue))))
21      (case x
22        ((bold) "1")
23        ((dark) "2")
24        ((underline) "4")
25        ((black) "30")
26        ((red) "31")
27        ((green) "32")
28        ((yellow) "33")
29        ((blue) "34")
30        ((magenta) "35")
31        ((cyan) "36")
32        ((white) "37")
33        (else "0"))))
34
35(define (ansi-escape color)
36  (cat (integer->char 27) "[" (color->ansi color) "m"))
37
38(define (fmt-in-html . args)
39  (fmt-let 'in-html? #t (apply-cat args)))
40
41(define (fmt-colored color . args)
42  (fmt-if fmt-in-html?
43          (cond
44            ((eq? color 'bold)
45             (cat "<b>" (apply-cat args) "</b>"))
46            ((eq? color 'underline)
47             (cat "<u>" (apply-cat args) "</u>"))
48            (else
49             (let ((cname (if (number? color) (cat "#" color) color)))
50               (fmt-if fmt-use-html-font?
51                       (cat "<font color=\"" cname "\">" (apply-cat args)
52                            "</font>")
53                       (cat "<span style=color:\"" cname "\">"
54                            (apply-cat args) "</span>")))))
55          (lambda (st)
56            (let ((old-color (fmt-color st)))
57              ((fmt-let 'color color
58                        (cat (ansi-escape color)
59                             (apply-cat args)
60                             (if (or (memv color '(bold underline))
61                                     (memv old-color '(bold underline)))
62                                 (ansi-escape 'reset)
63                                 (lambda (st) st))
64                             (ansi-escape old-color)))
65               st)))))
66
67(define (fmt-red . args) (fmt-colored 'red (apply-cat args)))
68(define (fmt-blue . args) (fmt-colored 'blue (apply-cat args)))
69(define (fmt-green . args) (fmt-colored 'green (apply-cat args)))
70(define (fmt-cyan . args) (fmt-colored 'cyan (apply-cat args)))
71(define (fmt-yellow . args) (fmt-colored 'yellow (apply-cat args)))
72(define (fmt-magenta . args) (fmt-colored 'magenta (apply-cat args)))
73(define (fmt-white . args) (fmt-colored 'white (apply-cat args)))
74(define (fmt-black . args) (fmt-colored 'black (apply-cat args)))
75(define (fmt-bold . args) (fmt-colored 'bold (apply-cat args)))
76(define (fmt-underline . args) (fmt-colored 'underline (apply-cat args)))
77
Note: See TracBrowser for help on using the repository browser.