From 9857c254979e7c43a3f432c1927a168d6437398c Mon Sep 17 00:00:00 2001
From: Jose Antonio Ortega Ruiz <jao@gnu.org>
Date: Sat, 26 Nov 2011 07:11:26 +0100
Subject: 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.
---
 scheme/racket/geiser/eval.rkt    |  5 +++--
 scheme/racket/geiser/modules.rkt | 26 +++++++++++++++++---------
 2 files changed, 20 insertions(+), 11 deletions(-)

(limited to 'scheme')

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)
-- 
cgit v1.2.3