unofficial mirror of guile-devel@gnu.org 
 help / color / mirror / Atom feed
* [PATCH] Colorized REPL
@ 2012-12-05  7:21 Nala Ginrut
  2012-12-05  8:23 ` Daniel Hartwig
  0 siblings, 1 reply; 52+ messages in thread
From: Nala Ginrut @ 2012-12-05  7:21 UTC (permalink / raw)
  To: guile-devel; +Cc: Ludovic Courtès

[-- Attachment #1: Type: text/plain, Size: 599 bytes --]

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!


[-- Attachment #2: 0001-repl-add-repl-option-for-customized-print.alt.patch --]
[-- Type: text/x-patch, Size: 2948 bytes --]

From 2251a259058524fbe631fd287c95b43882227f79 Mon Sep 17 00:00:00 2001
From: Daniel Hartwig <mandyke@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


[-- Attachment #3: 0002-ice-9-colorized-REPL-feature.patch --]
[-- Type: text/x-patch, Size: 9481 bytes --]

From 74972f91b6ae4e52d1195d4ea7eda927d2264832 Mon Sep 17 00:00:00 2001
From: Nala Ginrut <nalaginrut@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" <NalaGinrut@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


^ permalink raw reply related	[flat|nested] 52+ messages in thread

end of thread, other threads:[~2013-01-31 16:51 UTC | newest]

Thread overview: 52+ messages (download: mbox.gz follow: Atom feed
-- links below jump to the message on this page --
     [not found] <mailman.913570.1354697338.854.guile-devel@gnu.org>
2012-12-05  9:50 ` [PATCH] Colorized REPL Daniel Llorens
2012-12-05  9:57   ` Nala Ginrut
2012-12-05 10:11   ` Daniel Hartwig
2012-12-08 21:35   ` Ian Price
2012-12-09  0:50     ` Daniel Hartwig
2012-12-09 10:44       ` Nala Ginrut
2012-12-17  6:04       ` Nala Ginrut
2013-01-21 20:18   ` Andy Wingo
2013-01-28 10:57     ` Nala Ginrut
2012-12-05  7:21 Nala Ginrut
2012-12-05  8:23 ` Daniel Hartwig
2012-12-05  8:48   ` Nala Ginrut
2012-12-05  9:02     ` Nala Ginrut
2012-12-05  9:45     ` Daniel Hartwig
2012-12-05 10:27       ` Nala Ginrut
2012-12-05 11:19         ` Daniel Hartwig
2012-12-06  2:43           ` Nala Ginrut
2012-12-06  3:09             ` Daniel Hartwig
2012-12-06  4:28               ` Nala Ginrut
2012-12-06  5:30                 ` Daniel Hartwig
2012-12-09 23:29           ` Ludovic Courtès
2012-12-10  2:23             ` Nala Ginrut
2012-12-10 21:42               ` Ludovic Courtès
2012-12-11  2:31                 ` Nala Ginrut
2012-12-11 14:13                   ` Nala Ginrut
2012-12-31  8:29                 ` Nala Ginrut
2013-01-04 14:06                   ` Ludovic Courtès
2013-01-04 16:57                     ` Mike Gran
2013-01-09 10:17                     ` Nala Ginrut
     [not found]                       ` <CAN3veRfF5muf+zrfdU7ZogDw=YboW=QRP08zTF6NUeKzDJ__uA@mail.gmail.com>
2013-01-10  8:20                         ` Daniel Hartwig
2013-01-11  6:29                         ` Nala Ginrut
2013-01-11  8:13                           ` Daniel Hartwig
2013-01-11 10:40                             ` Nala Ginrut
2013-01-12  1:01                               ` Daniel Hartwig
2013-01-11 14:33                       ` Ludovic Courtès
2013-01-11 17:20                         ` Noah Lavine
2013-01-11 23:26                           ` Ludovic Courtès
2013-01-12 15:35                             ` Noah Lavine
2013-01-13 21:01                               ` Ludovic Courtès
2013-01-12  0:26                         ` Daniel Hartwig
2013-01-12  9:59                           ` Nala Ginrut
2013-01-12 21:16                           ` Ludovic Courtès
2013-01-26 10:15                             ` Nala Ginrut
2013-01-27 10:06                               ` Andy Wingo
2013-01-28  4:14                                 ` Nala Ginrut
2013-01-28 13:58                                   ` David Pirotte
2013-01-28 14:56                                     ` Nala Ginrut
2013-01-31 14:25                                       ` Nala Ginrut
2013-01-31 14:31                                         ` Nala Ginrut
2013-01-31 16:51                                           ` Nala Ginrut
2013-01-21 16:10                         ` Nala Ginrut
2013-01-22 11:06                         ` Nala Ginrut

This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).