Move test func to test-case. And I think all the issues fixed. Updated things attached. Thanks!
;; Copyright (C) 2013 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public ;;;; License as published by the Free Software Foundation; either ;;;; version 3 of the License, or (at your option) any later version. ;;;; ;;;; This library is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;;; Lesser General Public License for more details. ;;;; ;;;; You should have received a copy of the GNU Lesser General Public ;;;; License along with this library; if not, write to the Free Software ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA ;;;; Author: Mu Lei known as NalaGinrut <nalagin...@gmail.com> (define-module (ice-9 colorized) #:use-module (ice-9 rdelim) #:use-module ((srfi srfi-1) #:select (filter-map any proper-list?)) #:use-module (srfi srfi-9) #:use-module (system repl common) #:export (activate-colorized custom-colorized-set! color-it colorize-it colorize color-func colorize-string colorized-display add-color-scheme!)) (define (colorized-repl-printer repl val) (colorize-it val)) (define (activate-colorized) (let ((rs (fluid-ref *repl-stack*))) (if (null? rs) (repl-default-option-set! 'print colorized-repl-printer) ; if no REPL started, set as default printer (repl-option-set! (car rs) 'print colorized-repl-printer)))) ; or set as the top-REPL printer ;; color-scheme context, contains some info to be used (define-record-type color-scheme (make-color-scheme obj type color control method) color-scheme? (obj color-scheme-obj) ; the obj to be colored (type color-scheme-type) ; the obj type (for debug/test) (color color-scheme-color) ; the color (control color-scheme-control) ; ansi control code (method color-scheme-method)) ; colorized method for the obj type (define *color-list* `((CLEAR . "0") (RESET . "0") (BOLD . "1") (DARK . "2") (UNDERLINE . "4") (UNDERSCORE . "4") (BLINK . "5") (REVERSE . "6") (CONCEALED . "8") (BLACK . "30") (RED . "31") (GREEN . "32") (YELLOW . "33") (BLUE . "34") (MAGENTA . "35") (CYAN . "36") (WHITE . "37") (ON-BLACK . "40") (ON-RED . "41") (ON-GREEN . "42") (ON-YELLOW . "43") (ON-BLUE . "44") (ON-MAGENTA . "45") (ON-CYAN . "46") (ON-WHITE . "47"))) (define (get-color color) (assq-ref *color-list* color)) (define (generate-color colors) (let ((color-list (filter-map get-color colors))) (if (null? color-list) "" (string-append "\x1b[" (string-join color-list ";" 'infix) "m")))) (define (colorize-string-helper color str control) (string-append (generate-color color) str (generate-color control))) ;; test-helper functions ;; when eanbled, it won't output colored result, but just normal. ;; it used to test the array/list/vector print result. (define color-func (make-parameter colorize-string-helper)) (define (color-it cs) (let* ((obj (color-scheme-obj cs)) (str (object->string obj)) (color (color-scheme-color cs)) (control (color-scheme-control cs))) (color-it-inner color str control))) (define (color-it-inner color str control) ((color-func) color str control)) (define* (space #:optional (port (current-output-port))) (display #\sp port)) (define *pre-sign* `((LIST . "(") (PAIR . "(") (VECTOR . "#(") (ARRAY . #f))) ;; array's sign is complicated, return #f so it will be handled by pre-print (define* (pre-print cs #:optional (port (current-output-port))) (let* ((type (color-scheme-type cs)) (control (color-scheme-control cs)) (sign (assq-ref *pre-sign* type)) (color (color-scheme-color cs))) (if sign (display (color-it-inner color sign control) port) ; not array ;; array complecated coloring (display (color-array-inner cs) port)))) (define (print-dot port) (let ((light-cyan '(CYAN BOLD))) (display (color-it-inner light-cyan "." '(RESET)) port))) (define (delimiter? ch) (char-set-contains? char-set:punctuation ch)) (define (color-array-inner cs) (let* ((colors (color-scheme-color cs)) (control (color-scheme-control cs)) (sign-color (car colors)) (attr-color (cadr colors)) (str (object->string (color-scheme-obj cs))) (attrs (string->list (call-with-input-string str (lambda (p) (read-delimited "(" p)))))) (call-with-output-string (lambda (port) (for-each (lambda (ch) (let ((color (if (delimiter? ch) sign-color attr-color))) (display (color-it-inner color (string ch) control) port))) attrs) ;; output left-paren (display (color-it-inner sign-color "(" control) port))))) ;; Write a closing parenthesis. (define* (post-print cs #:optional (port (current-output-port))) (let* ((c (color-scheme-color cs)) (control (color-scheme-control cs)) (color (if (list? (car c)) (car c) c))) ; array has a color-list (display (color-it-inner color ")" control) port))) (define (color-integer cs) (color-it cs)) (define (color-char cs) (color-it cs)) (define (color-string cs) (color-it cs)) (define (color-list cs) (let* ((obj (color-scheme-obj cs))) (if (proper-list? obj) (call-with-output-string (lambda (port) (pre-print cs port) (display (string-join (map ->cstr obj) " ") port) (post-print cs port))) (color-pair cs)))) (define (color-pair cs) (let* ((obj (color-scheme-obj cs)) (d1 (car obj)) (d2 (cdr obj))) (call-with-output-string (lambda (port) (pre-print cs port) (colorize d1 port) (space port) (print-dot port) (space port) (colorize d2 port) (post-print cs port))))) (define (color-class cs) (color-it cs)) (define (color-procedure cs) (color-it cs)) (define (color-vector cs) (let ((ll (vector->list (color-scheme-obj cs)))) (call-with-output-string (lambda (port) (pre-print cs port) (display (string-join (map ->cstr ll) " ") port) (post-print cs port))))) (define (color-keyword cs) (color-it cs)) ;; TODO: maybe print it as char one by one? (define (color-char-set cs) (color-it cs)) (define (color-symbol cs) (color-it cs)) (define (color-stack cs) (color-it cs)) (define (color-record-type cs) (color-it cs)) (define (color-inexact cs) (color-it cs)) (define (color-exact cs) (let* ((obj (color-scheme-obj cs)) (colors (color-scheme-color cs)) (num-color (car colors)) (div-color (cadr colors)) (control (color-scheme-control cs)) (n (object->string (numerator obj))) (d (object->string (denominator obj)))) (call-with-output-string (lambda (port) (format port "~a~a~a" (color-it-inner num-color n control) (color-it-inner div-color "/" control) (color-it-inner num-color d control)))))) (define (color-regexp cs) (color-it cs)) (define (color-bitvector cs) ;; TODO: is it right? (color-it cs)) (define (color-boolean cs) (color-it cs)) (define (color-array cs) (let ((ll (array->list (color-scheme-obj cs)))) (call-with-output-string (lambda (port) (pre-print cs port) (display (string-join (map ->cstr ll) " ") port) (post-print cs port))))) (define (color-complex cs) (color-it cs)) (define (color-hashtable cs) (color-it cs)) (define (color-hook cs) (color-it cs)) (define (color-unknown cs) (color-it cs)) ;;--- custom color scheme --- (define *custom-colorized-list* (make-fluid '())) (define (custom-colorized-set! ll) (fluid-set! *custom-colorized-list* ll)) (define (current-custom-colorized) (fluid-ref *custom-colorized-list*)) (define (add-color-scheme! cs-list) (let ((ll (current-custom-colorized))) (custom-colorized-set! `(,@cs-list ,@ll)))) ;;--- custom color scheme end--- (define (is-inexact? obj) (and (number? obj) (inexact? obj))) (define (is-exact? obj) (and (number? obj) (exact? obj))) ;; A class is a struct. (define (class? obj) (struct? obj)) (define *colorize-list* `((,integer? INTEGER ,color-integer (BLUE BOLD)) (,char? CHAR ,color-char (YELLOW)) (,string? STRING ,color-string (RED)) (,list? LIST ,color-list (BLUE BOLD)) (,pair? PAIR ,color-list (BLACK BOLD)) ; NOTE: proper-list is a <pair>, and cons is <pair> too, so call color-list either. (,class? CLASS ,color-class (CYAN BOLD)) (,procedure? PROCEDURE ,color-procedure (YELLOW BOLD)) (,vector? VECTOR ,color-vector (MAGENTA BOLD)) (,keyword? KEYWORD ,color-keyword (MAGENTA)) (,char-set? CHAR-SET ,color-char-set (WHITE)) (,symbol? SYMBOL ,color-symbol (GREEN BOLD)) (,stack? STACK ,color-stack (MAGENTA)) (,record-type? RECORD-TYPE ,color-record-type (BLACK BOLD)) ;; We don't check REAL here, since it'll cover FLOAT and FRACTION, but user may customs it as they wish. (,is-inexact? FLOAT ,color-inexact (YELLOW)) (,is-exact? FRACTION ,color-exact ((BLUE BOLD) (YELLOW))) (,regexp? REGEXP ,color-regexp (GREEN)) (,bitvector? BITVECTOR ,color-bitvector (YELLOW BOLD)) (,array? ARRAY ,color-array ((CYAN BOLD) (YELLOW BOLD))) (,boolean? BOOLEAN ,color-boolean (BLUE)) (,complex? COMPLEX ,color-complex (MAGENTA)) (,hash-table? HASH-TABLE ,color-hashtable (BLUE)) (,hook? HOOK ,color-hook (GREEN)))) ;; TODO: if there's anything to add (define (obj->token-color obj) (let ((proc (lambda (x) (and ((car x) obj) (cdr x))))) (or (any proc (current-custom-colorized)) ; checkout user defined obj type (any proc *colorize-list*) ; checkout default obj type `(UNKNOWN ,color-unknown (WHITE))))) ; no suitable obj type ,return the unknown solution ;; NOTE: we don't use control now, but I write the mechanism for future usage. (define (generate-color-scheme obj) (let* ((r (obj->token-color obj)) (type (car r)) (method (cadr r)) (color (caddr r))) (make-color-scheme obj type color '(RESET) method))) (define (generate-custom-string-color-scheme str color) (make-color-scheme str #f color '(RESET) color-string)) (define (colorize-string str color) "Example: (colorize-string \"hello\" '(BLUE BOLD))" (and (not (list? color)) (error colorize-string "color should be a list!" color)) (colorize-string-helper color str '(RESET))) (define (colorized-display str color) "Example: (colorized-display \"hello\" '(BLUE BOLD))" (display (colorize-string str color))) (define* (colorize-it obj #:optional (port (current-output-port))) (colorize obj port) (newline port)) (define* (colorize obj #:optional (port (current-output-port))) (let* ((cs (generate-color-scheme obj)) (f (color-scheme-method cs))) (display (f cs) port))) (define (->cstr obj) (call-with-output-string (lambda (port) (colorize obj port))))
;;;; colorized.test --- test (ice-9 colorized) module -*- scheme -*- ;;;; ;;;; Copyright 2013 Free Software Foundation, Inc. ;;;; ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public ;;;; License as published by the Free Software Foundation; either ;;;; version 3 of the License, or (at your option) any later version. ;;;; ;;;; This library is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;;; Lesser General Public License for more details. ;;;; ;;;; You should have received a copy of the GNU Lesser General Public ;;;; License along with this library; if not, write to the Free Software ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA (define-module (test-suite test-ice-9-colorized) #:use-module (test-suite lib) #:use-module (oop goops) #:use-module (srfi srfi-9) #:use-module (ice-9 colorized)) ;; colorized-REPL test printer (define (color-it-test color str control) str) ;;; ;;; colorzed object test ;;; (define-record-type aaa (make-aaa a) aaa? (a a)) (define (test-me obj info) (parameterize ((color-func color-it-test)) (pass-if info (equal? (call-with-output-string (lambda (port) (colorize obj port))) (object->string obj))))) (with-test-prefix "colorized object tests" (test-me 123 "integer") (test-me #\c "char") (test-me "hello world\n" "string") (test-me '(1 2 3 4 5) "list") (test-me (cons 1 2) "pair") (test-me <integer> "class") (test-me + "procedure") (test-me (vector 1 2 3) "vector") (test-me #:test-me "keyword") (test-me char-set:ascii "char-set") (test-me 'test-me "symbol") (test-me (make-stack #t) "stack") (test-me aaa "record-type") (test-me 1.2 "inexact") (test-me 1/2 "exact") (test-me (make-regexp "[0-9]*") "regexp") (test-me (make-bitvector 8) "bitvector") (test-me #2u32@2@3((1 2) (3 4)) "array") (test-me #f "boolean false") (test-me #t "boolean true") (test-me 3+4i "complex") (test-me (make-hash-table) "hash table") (test-me (make-hook) "hook"))
>From 4e4acbe884716b0c84f1c39bc054244112daf17d Mon Sep 17 00:00:00 2001 From: Nala Ginrut <nalagin...@gmail.com> Date: Tue, 22 Jan 2013 19:02:06 +0800 Subject: [PATCH] Update manual for (ice-9 colorized). * doc/ref/misc-modules.texi: Add (ice-9 colorized). * doc/ref/scheme-using.texi: Add colorized REPL usage. --- doc/ref/misc-modules.texi | 91 +++++++++++++++++++++++++++++++++++++++++++++ doc/ref/scheme-using.texi | 35 ++++++++++++++++- 2 files changed, 125 insertions(+), 1 deletion(-) diff --git a/doc/ref/misc-modules.texi b/doc/ref/misc-modules.texi index cf1e0e4..770f354 100644 --- a/doc/ref/misc-modules.texi +++ b/doc/ref/misc-modules.texi @@ -1789,6 +1789,97 @@ example with the Scheme @code{read} function (@pxref{Scheme Read}), @end deffn +@node Colorized +@section Colorized + +@cindex Colorized +The module @code{(ice-9 colorized)} provides the procedure +@code{activate-colorized}, which provides colored REPL output. + +The module is loaded and activated by entering the following: + +@lisp +(use-modules (ice-9 colorized)) +(activate-colorized) +@end lisp + +And you may add your own color scheme with @code{add-color-scheme!}: + +@lisp +(add-color-scheme! `((,(lambda (data) + (and (number? data) (> data 10000))) + MY-LONG-NUM ,color-it (RED)))) +@print{} +Result: 10001 (in red color) +@end lisp + +@deffn {Scheme Procedure} activate-colorized +Activate colorized REPL. +@end deffn + +@deffn {Scheme Procedure} add-color-scheme! color-scheme-list +Add user defined color scheme. @code{color-scheme-list} consisted as: +@lisp +(list (pred scheme-name color-method color-list) + ;; other color scheme) +@end lisp +While @code{pred} is the predicate to checkout if it's the type you need, +@code{scheme-name} is a symbol you named this color scheme, +@code{color-method} is the color function, and it could be @code{color-it} +in default, and @code{color-list} is a ansi-color specific color list. +@end deffn + +@cindex Colorized String +Also exported by the @code{(ice-9 colorized)} module is +@code{colorize-string}, a procedure to format a string in certain color. + +@lisp +(use-modules (ice-9 colorized)) +(colorize-display "hello" '(BLUE BOLD)) +@print{} hello (in blue color and bold style) +(colorize-string "hello" '(BLUE BOLD)) +@print{} "\x1b[32;1mhello\x1b[0m" +(display (colorize-string "hello" '(BLUE BOLD))) +@print{} hello (in blue color and bold style) +@end lisp + +@deffn {Scheme Procedure} colorize-string str color +Return a string formated with @var{str} in @var{color} according to ansi +color specific. +@end deffn + +@deffn {Scheme Procedure} colorize-display str color +Print @var{str} in @var{color}. +@end deffn + +Here is the available colors: +CLEAR, +RESET, +BOLD, +DARK, +UNDERLINE, +UNDERSCORE, +BLINK, +REVERSE, +CONCEALED, +BLACK, +RED, +GREEN, +YELLOW, +BLUE, +MAGENTA, +CYAN, +WHITE, +ON-BLACK, +ON-RED, +ON-GREEN, +ON-YELLOW, +ON-BLUE, +ON-MAGENTA, +ON-CYAN, +ON-WHITE + + @c Local Variables: @c TeX-master: "guile.texi" @c End: diff --git a/doc/ref/scheme-using.texi b/doc/ref/scheme-using.texi index e0f91af..fe302c2 100644 --- a/doc/ref/scheme-using.texi +++ b/doc/ref/scheme-using.texi @@ -37,6 +37,7 @@ support for languages other than Scheme. @menu * Init File:: * Readline:: +* Colorized REPL:: * Value History:: * REPL Commands:: * Error Handling:: @@ -79,6 +80,37 @@ It's a good idea to put these two lines (without the @xref{Init File}, for more on @file{.guile}. +@node Colorized REPL +@subsection Colorized REPL + +To make colorized result in Guile REPL, or add your own color +schemes to show the result in colors. + +@lisp +scheme@@(guile-user)> (use-modules (ice-9 colorized)) +scheme@@(guile-user)> (activate-colorized) +@end lisp + +It's a good idea to put these two lines (without the +@code{scheme@@(guile-user)>} prompts) in your @file{.guile} file. +Besides, you may add your color schemes for the result: +@lisp +(add-color-scheme! (list (pred scheme-name color-method color-list))) +example: +(add-color-scheme! `((,(lambda (data) + (and (number? data) (> data 10000))) + MY-LONG-NUM ,color-it (RED)))) +10001 +@print{} 10001 (in red color) +@end lisp +While @code{pred} is the predicate to checkout if it's the type you need, +@code{scheme-name} is a symbol you named this color scheme, +@code{color-method} is the color function, and it could be @code{color-it} +in default, and @code{color-list} is a ansi-color specific color list, +please see @xref{Colorized}. +@xref{Init File}, for more on @file{.guile}. + + @node Value History @subsection Value History @@ -147,7 +179,8 @@ data structure or closure, they may then be reclaimed by the garbage collector. @cindex commands The REPL exists to read expressions, evaluate them, and then print their -results. But sometimes one wants to tell the REPL to evaluate an +results. But sometimes o +ne wants to tell the REPL to evaluate an expression in a different way, or to do something else altogether. A user can affect the way the REPL works with a @dfn{REPL command}. -- 1.7.10.4