Hi folks!
Here's a patch to add colorized-REPL.
With Daniel's optional REPL printer patch, this one based on the former
would print colored result more pretty than guile-colorized.
Thanks Daniel Hartwig!
And I didn't patch the doc to add an usage for this module, since it's
very easy, like (ice-9 readline):
-----------------cut-----------------
(use-modules (ice-9 colorized))
(activate-colorized)
-----------------end-----------------
And one may add these two lines to his/her '~/.guile'.
@ludo: I attached Daniel's patch in this mail, please apply in the order
if you accept them.
Thanks!
>From 2251a259058524fbe631fd287c95b43882227f79 Mon Sep 17 00:00:00 2001
From: Daniel Hartwig <mand...@gmail.com>
Date: Tue, 4 Dec 2012 11:41:35 +0800
Subject: [PATCH] repl: add repl-option for customized print
* module/system/repl/common.scm (repl-default-options)
(repl-print): Add option to use customized print procedure.
* doc/ref/scheme-using.texi (REPL Commands): Update.
---
doc/ref/scheme-using.texi | 4 ++++
module/system/repl/common.scm | 21 +++++++++++++++------
2 files changed, 19 insertions(+), 6 deletions(-)
diff --git a/doc/ref/scheme-using.texi b/doc/ref/scheme-using.texi
index 7eb84de..4f9e6db 100644
--- a/doc/ref/scheme-using.texi
+++ b/doc/ref/scheme-using.texi
@@ -445,6 +445,10 @@ choice is available. Off by default (indicating compilation).
@item prompt
A customized REPL prompt. @code{#f} by default, indicating the default
prompt.
+@item print
+A procedure of two arguments used to print the result of evaluating each
+expression. The arguments are the current REPL and the value to print.
+By default, @code{#f}, to use the default procedure.
@item value-history
Whether value history is on or not. @xref{Value History}.
@item on-error
diff --git a/module/system/repl/common.scm b/module/system/repl/common.scm
index 346ba99..3f3e785 100644
--- a/module/system/repl/common.scm
+++ b/module/system/repl/common.scm
@@ -119,6 +119,11 @@ See <http://www.gnu.org/licenses/lgpl.html>, for more details.")
((thunk? prompt) (lambda (repl) (prompt)))
((procedure? prompt) prompt)
(else (error "Invalid prompt" prompt)))))
+ (print #f ,(lambda (print)
+ (cond
+ ((not print) #f)
+ ((procedure? print) print)
+ (else (error "Invalid print procedure" print)))))
(value-history
,(value-history-enabled?)
,(lambda (x)
@@ -209,12 +214,16 @@ See <http://www.gnu.org/licenses/lgpl.html>, for more details.")
(if (not (eq? val *unspecified*))
(begin
(run-hook before-print-hook val)
- ;; The result of an evaluation is representable in scheme, and
- ;; should be printed with the generic printer, `write'. The
- ;; language-printer is something else: it prints expressions of
- ;; a given language, not the result of evaluation.
- (write val)
- (newline))))
+ (cond
+ ((repl-option-ref repl 'print)
+ => (lambda (print) (print repl val)))
+ (else
+ ;; The result of an evaluation is representable in scheme, and
+ ;; should be printed with the generic printer, `write'. The
+ ;; language-printer is something else: it prints expressions of
+ ;; a given language, not the result of evaluation.
+ (write val)
+ (newline))))))
(define (repl-option-ref repl key)
(cadr (or (assq key (repl-options repl))
--
1.7.10.4
>From 74972f91b6ae4e52d1195d4ea7eda927d2264832 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 | 290 ++++++++++++++++++++++++++++++++++++++++++++
1 file changed, 290 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..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.
+
+;; Ragnarok 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 General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+(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
