なんとなく、REPLに色をつけてみた。

別に0.3.4固有のものでもないのだけど、なんとなくREPLの画面に色をつけてみた。
WindowsのDOS窓は無理だけど。

(import (sagittarius vm)
 (sagittarius vm debug)
 (sagittarius interactive))
(cond-expand
 ((not windows)
  ;; colouring
  (define-syntax with-color
    (lambda (x)
      (syntax-case x ()
 ((_ color expr more ...)
  ;; on emacs it's useless.
  (if (getenv "EMACS")
      #'(begin expr more ...)
      #'(dynamic-wind
     (lambda () (display color))
     (lambda () expr more ...)
     (lambda () (display "\x1b;[m"))))))))
  (define-syntax with-color-red
    (lambda (x)
      (syntax-case x ()
 ((_ expr more ...)
  #'(with-color "\x1b;[1;31m" expr more ...)))))
  (define-syntax with-bold
    (lambda (x)
      (syntax-case x ()
 ((_ expr more ...)
  #'(with-color "\x1b;[1m" expr more ...)))))
  (define (printw . args) (for-each write/ss args) (newline))
  (current-printer (lambda args
       (with-bold
        (for-each printw args))))
  (current-exception-printer
   (lambda (c)
     (define (print-stack-trace)
       (let* ((stack (get-stack-trace-object))
       ;; skip the first get-stack-trace-object itself
       ;; and print-stack-trace
       ;; the last 2 are always evel and #f so skipt it as well
       (interesting (if (null? stack) stack (cddr (reverse! (cddr stack))))))
  (unless (null? interesting)
    (print "stack trace:")
    (do ((i 0 (+ i 1))
  (stack interesting (cdr stack)))
        ((or (= i 20) (null? stack)))
      (let* ((record (car stack))
      (index (- (car record) 2))
      (proc  (caddr record))
      (tmp   (cadddr record)))
        (format #t "  [~a] ~a~%" index proc)
        (when (and tmp (not (null? tmp)))
   (let* ((src (last-pair tmp))
   (info (source-info (cdar src))))
     (display "    src: ")
     (let ((s (call-with-string-output-port
        (lambda (o)
          (write/ss (unwrap-syntax (cdar src)) o)))))
       (if (> (string-length s) 50)
    (print (substring s 0 50) " ...")
    (print s)))
     (when info
       (format #t "    ~s:~a~%" (car info) (cdr info))))))))))
     (with-color-red
      (print (describe-condition c)))
     (print-stack-trace)))
  (current-prompter (lambda () (with-color "\x1b;[32m" (display "sash> "))))
  )
 (else #f))

ソース情報とか取得できないけど、いいかという感じでは動く。ソースもとるようにした。
これだけだとつまらないので、一応0.3.4から入った機能。「.sashrc」というファイルを$HOMEに置いて上記のソースを書いておけばREPL起動時に勝手に読み込んでくれる。このファイルはREPLだけが読み込むので、スクリプトでは無駄なライブラリのロードは起きない。