>From 92630700cda82c760f2b526c5c776a59f71b7372 Mon Sep 17 00:00:00 2001 From: Nala Ginrut
Date: Mon, 31 Dec 2012 16:11:23 +0800 Subject: [PATCH] Add new feture: colorized-REPL, and color string output. * new file: module/ice-9/colorized.scm --- module/ice-9/colorized.scm | 375 ++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 375 insertions(+) create mode 100644 module/ice-9/colorized.scm diff --git a/module/ice-9/colorized.scm b/module/ice-9/colorized.scm new file mode 100644 index 0000000..c6d280c --- /dev/null +++ b/module/ice-9/colorized.scm @@ -0,0 +1,375 @@ +;; Copyright (C) 2012 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 (ice-9 colorized) + #:use-module (oop goops) + #:use-module ((rnrs) #:select (bytevector->u8-list define-record-type + vector-for-each bytevector?)) + #:use-module (ice-9 rdelim) + #:use-module ((srfi srfi-1) #:select (remove proper-list?)) + #:use-module (system repl common) + #:export (activate-colorized custom-colorized-set! color-it + string-in-color add-color-scheme! display-in-color)) + +(define (colorized-repl-printer repl val) + (colorize-it val)) + +(define (activate-colorized) + (repl-default-option-set! 'print colorized-repl-printer)) + +(define-record-type color-scheme + (fields str data type color control method)) + +(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 + (lambda (color) + (assoc-ref *color-list* color))) + +(define generate-color + (lambda (colors) + (let ((color-list + (remove not + (map (lambda (c) (assoc-ref *color-list* c)) colors)))) + (if (null? color-list) + "" + (string-join color-list ";" 'infix))))) + +(define color-it + (lambda (cs) + (let* ((str (color-scheme-str cs)) + (color (color-scheme-color cs)) + (control (color-scheme-control cs))) + (color-it-inner color str control)))) + +(define color-it-inner + (lambda (color str control) + (string-append "\x1b[" (generate-color color) "m" str "\x1b[" (generate-color control) "m"))) + +(define* (space #:optional (port (current-output-port))) + (display #\sp port)) + +(define (backspace port) + (seek port -1 SEEK_CUR)) + +(define *pre-sign* + `((LIST . "(") + (PAIR . "(") + (VECTOR . "#(") + (BYTEVECTOR . "#vu8(") + (ARRAY . #f))) ;; array's sign is complecated. + +(define* (pre-print cs #:optional (port (current-output-port))) + (let* ((type (color-scheme-type cs)) + (control (color-scheme-control cs)) + (sign (assoc-ref *pre-sign* type)) + (color (color-scheme-color cs))) ;; (car color) is the color, (cdr color) is the control + (if sign + (display (color-it-inner color sign control) port) ;; not array + (display (color-array-inner cs) port) ;; array complecated coloring + ))) + +(define (print-dot port) + (let ((light-cyan '(CYAN BOLD))) + (display (color-it-inner light-cyan "." '(RESET)) port))) + +(define is-sign? + (lambda (ch) + (char-set-contains? char-set:punctuation ch))) + +(define color-array-inner + (lambda (cs) + (let* ((colors (color-scheme-color cs)) + (control (color-scheme-control cs)) + (sign-color (car colors)) + (attr-color (cadr colors)) + (str (color-scheme-str 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 (is-sign? ch) sign-color attr-color))) + (display (color-it-inner color (string ch) control) port))) + attrs) + (display (color-it-inner sign-color "(" control) port) ;; output right-parent + ))))) + +;; I believe all end-sign is ")" +(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* ((data (color-scheme-data cs))) + (if (proper-list? data) + (call-with-output-string + (lambda (port) + (pre-print cs port) + (for-each (lambda (x) (colorize x port) (space port)) data) + (backspace port) ;; remove the redundant space + (post-print cs port))) + (color-pair cs)))) + +(define (color-pair cs) + (let* ((data (color-scheme-data cs)) + (d1 (car data)) + (d2 (cdr data))) + (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 ((vv (color-scheme-data cs))) + (call-with-output-string + (lambda (port) + (pre-print cs port) + (vector-for-each (lambda (x) (colorize x port) (space port)) vv) + (backspace port) ;; remove the redundant space + (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* ((data (color-scheme-data cs)) + (colors (color-scheme-color cs)) + (num-color (car colors)) + (div-color (cadr colors)) + (control (color-scheme-control cs)) + (n (object->string (numerator data))) + (d (object->string (denominator data)))) + (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-bytevector cs) + (let ((ll (bytevector->u8-list (color-scheme-data cs)))) + (call-with-output-string + (lambda (port) + (pre-print cs port) + (for-each (lambda (x) (colorize x port) (space port)) ll) + (backspace port) ;; remove the redundant space + (post-print cs port))))) + +(define (color-boolean cs) + (color-it cs)) + +(define (color-arbiter cs) + (color-it cs)) + +(define (color-array cs) + (let ((ll (array->list (color-scheme-data cs)))) + (call-with-output-string + (lambda (port) + (pre-print cs port) + (for-each (lambda (x) (colorize x port) (space port)) ll) ;; easy life to use list rather than array. + (backspace port) ;; remove the redundant space + (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))) + +(define (class? obj) + (is-a? obj