mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-07-08 13:37:35 +02:00
adding (chibi show color) and (chibi show unicode)
This commit is contained in:
Alex Shinn
parent
8d51cf053c
commit
0e4b4d6127
5 changed files with 202 additions and 2 deletions
|
|
@ -2,8 +2,9 @@
|
||||||
(export run-tests)
|
(export run-tests)
|
||||||
(import (scheme base) (scheme char) (scheme read)
|
(import (scheme base) (scheme char) (scheme read)
|
||||||
(chibi test)
|
(chibi test)
|
||||||
(chibi show) (chibi show base)
|
(chibi show) (chibi show base) (chibi show color)
|
||||||
(chibi show column) (chibi show pretty))
|
(chibi show column) (chibi show pretty)
|
||||||
|
(chibi show unicode))
|
||||||
(begin
|
(begin
|
||||||
(define-syntax test-pretty
|
(define-syntax test-pretty
|
||||||
(syntax-rules ()
|
(syntax-rules ()
|
||||||
|
|
@ -581,4 +582,15 @@ def | 6
|
||||||
(tabular (each "a\nbc\ndef\n") " | "
|
(tabular (each "a\nbc\ndef\n") " | "
|
||||||
(each "123\n45\n6\n")))))
|
(each "123\n45\n6\n")))))
|
||||||
|
|
||||||
|
;; color
|
||||||
|
(test "\x1B;[31mred\x1B;[0m" (show #f (as-red "red")))
|
||||||
|
(test "\x1B;[31mred\x1B;[34mblue\x1B;[31mred\x1B;[0m"
|
||||||
|
(show #f (as-red "red" (as-blue "blue") "red")))
|
||||||
|
|
||||||
|
;; unicode
|
||||||
|
(test "〜日本語〜"
|
||||||
|
(show #f (with ((pad-char #\〜)) (padded/both 5 "日本語"))))
|
||||||
|
(test "日本語"
|
||||||
|
(show #f (as-unicode (with ((pad-char #\〜)) (padded/both 5 "日本語")))))
|
||||||
|
|
||||||
(test-end))))
|
(test-end))))
|
||||||
|
|
|
||||||
43
lib/chibi/show/color.scm
Normal file
43
lib/chibi/show/color.scm
Normal file
|
|
@ -0,0 +1,43 @@
|
||||||
|
;; color.scm -- colored output
|
||||||
|
;; Copyright (c) 2006-2017 Alex Shinn. All rights reserved.
|
||||||
|
;; BSD-style license: http://synthcode.com/license.txt
|
||||||
|
|
||||||
|
(define (color->ansi x)
|
||||||
|
(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)
|
||||||
|
(each (integer->char 27) "[" (color->ansi color) "m"))
|
||||||
|
|
||||||
|
(define (colored new-color . args)
|
||||||
|
(fn (color)
|
||||||
|
(with ((color new-color))
|
||||||
|
(each (ansi-escape new-color)
|
||||||
|
(each-in-list args)
|
||||||
|
(if (or (memq new-color '(bold underline))
|
||||||
|
(memq color '(bold underline)))
|
||||||
|
(ansi-escape 'reset)
|
||||||
|
nothing)
|
||||||
|
(ansi-escape color)))))
|
||||||
|
|
||||||
|
(define (as-red . args) (colored 'red (each-in-list args)))
|
||||||
|
(define (as-blue . args) (colored 'blue (each-in-list args)))
|
||||||
|
(define (as-green . args) (colored 'green (each-in-list args)))
|
||||||
|
(define (as-cyan . args) (colored 'cyan (each-in-list args)))
|
||||||
|
(define (as-yellow . args) (colored 'yellow (each-in-list args)))
|
||||||
|
(define (as-magenta . args) (colored 'magenta (each-in-list args)))
|
||||||
|
(define (as-white . args) (colored 'white (each-in-list args)))
|
||||||
|
(define (as-black . args) (colored 'black (each-in-list args)))
|
||||||
|
(define (as-bold . args) (colored 'bold (each-in-list args)))
|
||||||
|
(define (as-underline . args) (colored 'underline (each-in-list args)))
|
||||||
6
lib/chibi/show/color.sld
Normal file
6
lib/chibi/show/color.sld
Normal file
|
|
@ -0,0 +1,6 @@
|
||||||
|
|
||||||
|
(define-library (chibi show color)
|
||||||
|
(import (scheme base) (chibi show base))
|
||||||
|
(export as-red as-blue as-green as-cyan as-yellow
|
||||||
|
as-magenta as-white as-black as-bold)
|
||||||
|
(include "color.scm"))
|
||||||
134
lib/chibi/show/unicode.scm
Normal file
134
lib/chibi/show/unicode.scm
Normal file
|
|
@ -0,0 +1,134 @@
|
||||||
|
;; unicode.scm -- Unicode character width and ANSI escape support
|
||||||
|
;; Copyright (c) 2006-2017 Alex Shinn. All rights reserved.
|
||||||
|
;; BSD-style license: http://synthcode.com/license.txt
|
||||||
|
|
||||||
|
;; a condensed non-spacing mark range from UnicodeData.txt (chars with
|
||||||
|
;; the Mn property) - generated partially by hand, should automate
|
||||||
|
;; this better
|
||||||
|
|
||||||
|
(define low-non-spacing-chars
|
||||||
|
(bytevector
|
||||||
|
#xff #xff #xff #xff #xff #xff #xff #xff #xff #xff #xff #xff #xff #xff 0 0
|
||||||
|
0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
|
||||||
|
0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
|
||||||
|
#x78 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
|
||||||
|
0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
|
||||||
|
0 0 #xfe #xff #xff #xff #xff #xff #x1f 0 0 0 0 0 0 0
|
||||||
|
0 0 #x3f 0 0 0 0 0 0 #xf8 #xff #x01 0 0 #x01 0
|
||||||
|
0 0 0 0 0 0 0 0 0 0 #xc0 #xff #xff #x3f 0 0
|
||||||
|
0 0 #x02 0 0 0 #xff #xff #xff #x07 0 0 0 0 0 0
|
||||||
|
0 0 0 0 #xc0 #xff #x01 0 0 0 0 0 0 0 0 0
|
||||||
|
0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
|
||||||
|
0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
|
||||||
|
#x06 0 0 0 0 0 0 #x10 #xfe #x21 #x1e 0 #x0c 0 0 0
|
||||||
|
#x02 0 0 0 0 0 0 #x10 #x1e #x20 0 0 #x0c 0 0 0
|
||||||
|
#x06 0 0 0 0 0 0 #x10 #xfe #x3f 0 0 0 0 #x03 0
|
||||||
|
#x06 0 0 0 0 0 0 #x30 #xfe #x21 0 0 #x0c 0 0 0
|
||||||
|
#x02 0 0 0 0 0 0 #x90 #x0e #x20 #x40 0 0 0 0 0
|
||||||
|
#x04 0 0 0 0 0 0 0 0 #x20 0 0 0 0 0 0
|
||||||
|
0 0 0 0 0 0 0 #xc0 #xc1 #xff #x7f 0 0 0 0 0
|
||||||
|
0 0 0 0 0 0 0 #x10 #x40 #x30 0 0 0 0 0 0
|
||||||
|
0 0 0 0 0 0 0 0 #x0e #x20 0 0 0 0 0 0
|
||||||
|
0 0 0 0 0 0 0 0 0 #x04 #x7c 0 0 0 0 0
|
||||||
|
0 0 0 0 0 0 #xf2 #x07 #x80 #x7f 0 0 0 0 0 0
|
||||||
|
0 0 0 0 0 0 #xf2 #x1f 0 #x3f 0 0 0 0 0 0
|
||||||
|
0 0 0 #x03 0 0 #xa0 #x02 0 0 0 0 0 0 #xfe #x7f
|
||||||
|
#xdf 0 #xff #xff #xff #xff #xff #x1f #x40 0 0 0 0 0 0 0
|
||||||
|
0 0 0 0 0 #xe0 #xfd #x02 0 0 0 #x03 0 0 0 0
|
||||||
|
0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
|
||||||
|
0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
|
||||||
|
0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
|
||||||
|
0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
|
||||||
|
0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
|
||||||
|
0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
|
||||||
|
0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
|
||||||
|
0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
|
||||||
|
0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
|
||||||
|
0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
|
||||||
|
0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
|
||||||
|
0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
|
||||||
|
0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
|
||||||
|
0 0 #x1c 0 0 0 #x1c 0 0 0 #x0c 0 0 0 #x0c 0
|
||||||
|
0 0 0 0 0 0 #x80 #x3f #x40 #xfe #x0f #x20 0 0 0 0
|
||||||
|
0 #x38 0 0 0 0 0 0 0 0 0 0 0 0 0 0
|
||||||
|
0 0 0 0 0 #x02 0 0 0 0 0 0 0 0 0 0
|
||||||
|
0 0 0 0 #x87 #x01 #x04 #x0e 0 0 0 0 0 0 0 0
|
||||||
|
0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
|
||||||
|
0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
|
||||||
|
0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
|
||||||
|
0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
|
||||||
|
0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
|
||||||
|
0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
|
||||||
|
0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
|
||||||
|
0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
|
||||||
|
0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
|
||||||
|
0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
|
||||||
|
0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
|
||||||
|
0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
|
||||||
|
0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
|
||||||
|
0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
|
||||||
|
0 0 0 0 0 0 0 0 0 0 #xff #x1f #xe2 #x07
|
||||||
|
))
|
||||||
|
|
||||||
|
(define (unicode-char-width c)
|
||||||
|
(let ((ci (char->integer c)))
|
||||||
|
(cond
|
||||||
|
;; hand-checked ranges from EastAsianWidth.txt
|
||||||
|
((<= #x1100 ci #x115F) 2) ; Hangul
|
||||||
|
((<= #x2E80 ci #x4DB5) 2) ; CJK
|
||||||
|
((<= #x4E00 ci #xA4C6) 2)
|
||||||
|
((<= #xAC00 ci #xD7A3) 2) ; Hangul
|
||||||
|
((<= #xF900 ci #xFAD9) 2) ; CJK compat
|
||||||
|
((<= #xFE10 ci #xFE6B) 2)
|
||||||
|
((<= #xFF01 ci #xFF60) 2)
|
||||||
|
((<= #xFFE0 ci #xFFE6) 2)
|
||||||
|
((<= #x20000 ci #x30000) 2)
|
||||||
|
;; non-spacing mark (Mn) ranges from UnicodeData.txt
|
||||||
|
((<= #x0300 ci #x3029)
|
||||||
|
;; inlined bit-vector-ref for portability
|
||||||
|
(let* ((i (- ci #x0300))
|
||||||
|
(byte (quotient i 8))
|
||||||
|
(off (remainder i 8)))
|
||||||
|
(if (zero? (bitwise-and (bytevector-u8-ref low-non-spacing-chars byte)
|
||||||
|
(arithmetic-shift 1 off)))
|
||||||
|
1
|
||||||
|
0)))
|
||||||
|
((<= #x302A ci #x302F) 0)
|
||||||
|
((<= #x3099 ci #x309A) 0)
|
||||||
|
((= #xFB1E ci) 0)
|
||||||
|
((<= #xFE00 ci #xFE23) 0)
|
||||||
|
((<= #x1D167 ci #x1D169) 0)
|
||||||
|
((<= #x1D17B ci #x1D182) 0)
|
||||||
|
((<= #x1D185 ci #x1D18B) 0)
|
||||||
|
((<= #x1D1AA ci #x1D1AD) 0)
|
||||||
|
((<= #xE0100 ci #xE01EF) 0)
|
||||||
|
(else 1))))
|
||||||
|
|
||||||
|
(define (unicode-terminal-width str . o)
|
||||||
|
(let ((start (if (pair? o) (car o) 0))
|
||||||
|
(end (if (and (pair? o) (pair? (cdr o)))
|
||||||
|
(cadr o)
|
||||||
|
(string-length str))))
|
||||||
|
(let lp1 ((i start) (width 0))
|
||||||
|
(if (>= i end)
|
||||||
|
width
|
||||||
|
(let ((c (string-ref str i)))
|
||||||
|
(cond
|
||||||
|
;; ANSI escapes
|
||||||
|
((and (= 27 (char->integer c)) ; esc
|
||||||
|
(< (+ i 1) end)
|
||||||
|
(eqv? #\[ (string-ref str (+ i 1))))
|
||||||
|
(let lp2 ((i (+ i 2)))
|
||||||
|
(cond ((>= i end) width)
|
||||||
|
((memv (string-ref str i) '(#\m #\newline))
|
||||||
|
(lp1 (+ i 1) width))
|
||||||
|
(else (lp2 (+ i 1))))))
|
||||||
|
;; unicode characters
|
||||||
|
((>= (char->integer c) #x80)
|
||||||
|
(lp1 (+ i 1) (+ width (unicode-char-width c))))
|
||||||
|
;; normal ASCII
|
||||||
|
(else (lp1 (+ i 1) (+ width 1)))))))))
|
||||||
|
|
||||||
|
(define (as-unicode . args)
|
||||||
|
(with ((string-width unicode-terminal-width))
|
||||||
|
(each-in-list args)))
|
||||||
5
lib/chibi/show/unicode.sld
Normal file
5
lib/chibi/show/unicode.sld
Normal file
|
|
@ -0,0 +1,5 @@
|
||||||
|
|
||||||
|
(define-library (chibi show unicode)
|
||||||
|
(import (scheme base) (chibi show base) (srfi 151))
|
||||||
|
(export as-unicode unicode-terminal-width)
|
||||||
|
(include "unicode.scm"))
|
||||||
Loading…
Add table
Reference in a new issue