Racket: capturing and displaying standard error during evaluation

This bugs was exposed by using rackunit, where all the output of, say,
check-eq? was lost for good (it was being sent to the stderr black
hole).

Hat tip Grant Retkke.

4 files changed, 27 insertions, 18 deletions

diff --git a/elisp/geiser-debug.el b/elisp/geiser-debug.el
index 0d76fde..d7cf338 100644
--- a/elisp/geiser-debug.el
+++ b/elisp/geiser-debug.el
@@ -1,6 +1,6 @@
 ;;; geiser-debug.el -- displaying debug information and evaluation results
 
-;; Copyright (C) 2009, 2010 Jose Antonio Ortega Ruiz
+;; Copyright (C) 2009, 2010, 2011 Jose Antonio Ortega Ruiz
 
 ;; This program is free software; you can redistribute it and/or
 ;; modify it under the terms of the Modified BSD License. You should
@@ -120,7 +120,7 @@ buffer.")
       (erase-buffer)
       (when dir (setq default-directory dir))
       (unless after
-        (insert what)
+        (geiser-debug--display-error impl module nil what)
         (newline 2))
       (when (and res (not err))
         (insert res)
@@ -128,7 +128,8 @@ buffer.")
       (setq jump (geiser-debug--display-error impl module key output))
       (when after
         (goto-char (point-max))
-        (insert "\nExpression evaluated was:\n\n" what))
+        (insert "\nExpression evaluated was:\n\n")
+        (geiser-debug--display-error impl module nil what))
       (goto-char (point-min)))
     (when jump (geiser-debug--pop-to-buffer))))
 
diff --git a/elisp/geiser-racket.el b/elisp/geiser-racket.el
index ff7b738..6e2de6b 100644
--- a/elisp/geiser-racket.el
+++ b/elisp/geiser-racket.el
@@ -213,13 +213,12 @@ This function uses `geiser-racket-init-file' if it exists."
   (when msg
     (let ((p (point)))
       (insert msg)
-      (when key
-        (let ((end (point)))
+      (let ((end (point)))
         (goto-char p)
-        (geiser-racket--purge-trace)
+        (when key (geiser-racket--purge-trace))
         (mapc 'geiser-edit--buttonize-files geiser-racket--file-rxs)
         (goto-char end)
-        (newline)))))
+        (newline))))
   (or key (not (zerop (length msg)))))
 
 
diff --git a/scheme/racket/geiser/eval.rkt b/scheme/racket/geiser/eval.rkt
index a59e275..26ad959 100644
--- a/scheme/racket/geiser/eval.rkt
+++ b/scheme/racket/geiser/eval.rkt
@@ -47,8 +47,9 @@
   (let ([output
          (with-output-to-string
            (lambda ()
-             (with-handlers ([exn? set-last-error])
-               (call-with-values thunk set-last-result))))])
+             (parameterize ([current-error-port (current-output-port)])
+               (with-handlers ([exn? set-last-error])
+                 (call-with-values thunk set-last-result)))))])
     (append last-result `((output . ,output)))))
 
 (define (eval-in form spec lang)
diff --git a/scheme/racket/geiser/modules.rkt b/scheme/racket/geiser/modules.rkt
index 2c57db9..befe2bc 100644
--- a/scheme/racket/geiser/modules.rkt
+++ b/scheme/racket/geiser/modules.rkt
@@ -71,11 +71,14 @@
 
 (define unknown-module-name "*unresolved module*")
 
+(define (unix-path->string path)
+  (regexp-replace* "\\\\" (path->string path) "/"))
+
 (define (module-path-name->name path)
-  (cond [(path? path) (module-path-name->name (path->string path))]
+  (cond [(path? path) (module-path-name->name (unix-path->string path))]
         ;; [(eq? path '#%kernel) "(kernel)"]
         [(string? path)
-         (let* ([cpaths (map (compose path->string path->directory-path)
+         (let* ([cpaths (map (compose unix-path->string path->directory-path)
                              (current-library-collection-paths))]
                 [prefix-len (lambda (p)
                               (let ((pl (string-length p)))
@@ -85,9 +88,9 @@
                 [lens (map prefix-len cpaths)]
                 [real-path (substring path (apply max lens))])
            (if (absolute-path? real-path)
-               (let-values ([(_ base __) (split-path path)])
-                 (path->string base))
-               (regexp-replace "\\.[^./]*$" real-path "")))]
+             (let-values ([(_ base __) (split-path path)])
+               (unix-path->string base))
+             (regexp-replace "\\.[^./]*$" real-path "")))]
         [(symbol? path) (symbol->string path)]
         [else unknown-module-name]))
 
@@ -116,17 +119,22 @@
     (lambda (_ basename __)
       (member (path->string basename) '(".svn" "compiled")))))
 
-(define path->symbol (compose string->symbol path->string))
+(define path->symbol (compose string->symbol unix-path->string))
 
 (define (path->entry path)
   (let ([ext (filename-extension path)])
     (and ext
          (or (bytes=? ext #"rkt") (bytes=? ext #"ss"))
          (not (bytes=? (bytes-append #"main" ext) (path->bytes path)))
-         (let* ([path (path->string path)]
+         (let* ([path (unix-path->string path)]
                 [len (- (string-length path) (bytes-length ext) 1)])
            (substring path 0 len)))))
 
+(define (ensure-path datum)
+  (if (string? datum)
+      (string->path datum)
+      datum))
+
 (define main-rkt (build-path "main.rkt"))
 (define main-ss (build-path "main.ss"))
 
@@ -144,7 +152,7 @@
     [(file) (let ([entry (path->entry path)])
               (if (not entry) acc (register entry path)))]
     [(dir) (cond [(skippable-dir? path) (values acc #f)]
-                 [(find-main path) => (curry register (path->string path))]
+                 [(find-main path) => (curry register (unix-path->string path))]
                  [else (values acc reg?)])]
     [else acc]))
 
@@ -175,7 +183,7 @@
        (let-values ([(dir base ign) (split-path path)])
          (and (or (equal? base main-rkt)
                   (equal? base main-ss))
-              (map (lambda (m) (path->string (build-path dir m)))
+              (map (lambda (m) (unix-path->string (build-path dir m)))
                    (remove "main" ((find-modules #f) dir '())))))))
 
 (define (known-modules)