On Wed, 2012-12-05 at 16:23 +0800, Daniel Hartwig wrote:
> On 5 December 2012 15:21, Nala Ginrut <nalagin...@gmail.com> wrote:
> > Hi folks!
> > Here's a patch to add colorized-REPL.
>
> Some comments :-)
>
> diff --git a/module/ice-9/colorized.scm b/module/ice-9/colorized.scm
> new file mode 100644
> index 0000000..fe42a9a
> --- /dev/null
> +++ b/module/ice-9/colorized.scm
> @@ -0,0 +1,290 @@
> +;; Copyright (C) 2012
> +;; "Mu Lei" known as "NalaGinrut" <nalagin...@gmail.com>
> +;; Ragnarok is free software: you can redistribute it and/or modify
> +;; it under the terms of the GNU General Public License as published by
> +;; the Free Software Foundation, either version 3 of the License, or
> +;; (at your option) any later version.
>
> Contributions to GNU must have the copyright assigned to FSF, no?
>
>
Oh~I'm very sorry! I just copied the header from one of my project!
> + #:use-module (oop goops)
>
> This module seems only used to determine the type of each datum for
> assigning a colour:
>
> +(define *colorize-list*
> + `((,<integer> ,color-integer light-blue)
> + (,<char> ,color-char brown)
>
> The datums tested for are all primitives. For reference, the
> “class-of” operator is more-or-less equivalent to:
>
> (cond
> ((integer? x) <interge>)
> ((char? x) <char>)
> …
>
> Is there some advantage to using the GOOPS classes rather than
> equivalent predicates, which are more universal? Of course, the order
> of the tests matters highly in both cases.
>
GOOPS classes covered all the possible types in Guile, and it's easy to
detect the type of a datum with class-of. I just choose the simplest way
which I can imagined.
>
> There is already a guile-lib module (ansi term-color) that has a
> particular syntax and defines the codes. It would be excellent to
> make use of it here, or at least share the syntax and avoid some
> duplication.
>
The code segment of the color is not so big, so I write my own.
And it's not easy to do a quick hack with mixing other guy's code.
For a quick hack, and it's simple, so I have no time to care about
reusing other's work. I don't think it's proper to use (ansi term-color)
purposely, since it's not in Guile.
PS: A fixed patch attached.
>
> Regards
>
>From a2c3d6d1873c14ff1dbc64081003ce4c0ad0e844 Mon Sep 17 00:00:00 2001
From: Nala Ginrut <nalagin...@gmail.com>
Date: Wed, 5 Dec 2012 14:51:53 +0800
Subject: [PATCH] ice-9: colorized REPL feature.
* new file: module/ice-9/colorized.scm
---
module/ice-9/colorized.scm | 291 ++++++++++++++++++++++++++++++++++++++++++++
1 file changed, 291 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..7c59872
--- /dev/null
+++ b/module/ice-9/colorized.scm
@@ -0,0 +1,291 @@
+;; 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)
+ #:use-module (ice-9 rdelim)
+ #:use-module (srfi srfi-1)
+ #:use-module (system repl common)
+ #:export (activate-colorized))
+
+(define (colorized-repl-printer repl val)
+ (colorize-it val))
+
+(define (activate-colorized)
+ (repl-option-set! (car (fluid-ref *repl-stack*))
+ 'print colorized-repl-printer))
+
+(define-record-type color-scheme
+ (fields str data class color control method))
+
+(define *color-list*
+ '((nothing . "0;0")
+ (black . "0;30")
+ (red . "0;31")
+ (green . "0;32")
+ (brown . "0;33")
+ (blue . "0;34")
+ (cyan . "0;36")
+ (purple . "0;35")
+ (light-gray . "0;37")
+ (dark-gray . "1;30")
+ (light-red . "1;31")
+ (light-green . "1;32")
+ (yellow . "1;33")
+ (light-blue . "1;34")
+ (light-cyan . "1;36")
+ (light-purple . "1;35")
+ (white . "1;37")))
+
+(define get-color
+ (lambda (color)
+ (assoc-ref *color-list* color)))
+
+(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[" (get-color color) "m" str "\x1b[" control "m")))
+
+(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* ((class (color-scheme-class cs))
+ (control (color-scheme-control cs))
+ (sign (assoc-ref *pre-sign* class))
+ (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)
+ (display (color-it-inner 'light-cyan "." "0") 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? 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) (display " " port)) data)
+ (seek port -1 SEEK_CUR)
+ (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)
+ (display " " port) (print-dot port) (display " " 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) (display " " port)) vv)
+ (seek port -1 SEEK_CUR)
+ (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-real cs)
+ (color-it cs))
+
+(define (color-fraction 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)
+ (display (color-it-inner num-color n control) port)
+ (display (color-it-inner div-color "/" control) port)
+ (display (color-it-inner num-color d control) port)))))
+
+(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) (display " " port)) ll)
+ (seek port -1 SEEK_CUR)
+ (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) (display " " port)) ll) ;; easy life to use list rather than array.
+ (seek port -1 SEEK_CUR)
+ (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))
+
+
+(define *colorize-list*
+ `((,<integer> ,color-integer light-blue)
+ (,<char> ,color-char brown)
+ (,<string> ,color-string red)
+ (,<list> ,color-list light-blue)
+ (,<pair> ,color-list light-gray) ;; NOTE: proper-list is a <pair>, and cons is <pair> too, so call color-list either.
+ (,<class> ,color-class light-cyan)
+ (,<procedure> ,color-procedure yellow)
+ (,<vector> ,color-vector light-purple)
+ (,<keyword> ,color-keyword purple)
+ (,<character-set> ,color-char-set white)
+ (,<symbol> ,color-symbol light-green)
+ (,<stack> ,color-stack purple)
+ (,<record-type> ,color-record-type dark-gray)
+ (,<real> ,color-real yellow)
+ (,<fraction> ,color-fraction (light-blue yellow))
+ (,<regexp> ,color-regexp green)
+ (,<bitvector> ,color-bitvector brown)
+ (,<bytevector> ,color-bytevector cyan)
+ (,<boolean> ,color-boolean blue)
+ (,<arbiter> ,color-arbiter blue)
+ (,<array> ,color-array (light-cyan brown))
+ (,<complex> ,color-complex purple)
+ (,<hashtable> ,color-hashtable blue)
+ (,<hook> ,color-hook green)
+ (,<unknown> ,color-unknown white)
+ ;; TODO: if there's anything to add
+ ))
+
+;; NOTE: we don't use control now, but I write the mechanism for future usage.
+(define generate-color-scheme
+ (lambda (data)
+ (let* ((class (class-of data))
+ (str (object->string data))
+ (r (assoc-ref *colorize-list* class))
+ (method (car r))
+ (color (cadr r)))
+ (make-color-scheme str data class color "0" method))))
+
+(define* (colorize-it data #:optional (port (current-output-port)))
+ (colorize data port)
+ (newline port))
+
+(define* (colorize data #:optional (port (current-output-port)))
+ (let* ((cs (generate-color-scheme data))
+ (f (color-scheme-method cs)))
+ (display (f cs) port)))
+
+
+
--
1.7.10.4
