From 220b23630cb03cfe92407d547bc6a5c0e5ff7df7 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= <georges.duperon@gmail.com>
Date: Wed, 30 Mar 2016 19:35:54 +0200
Subject: [PATCH] Fixes GH issue #2 and #3

---
 lang/reader.rkt              | 98 ++++++------------------------------
 private/run-interactions.rkt | 43 ++++++++++++++++
 private/util.rkt             | 54 ++++++++++++++++++++
 test/meta.rkt                | 22 ++++++++
 test/simple.rkt              |  3 ++
 test/test.rkt                | 22 ++------
 6 files changed, 139 insertions(+), 103 deletions(-)
 create mode 100644 private/run-interactions.rkt
 create mode 100644 private/util.rkt
 create mode 100644 test/meta.rkt
 create mode 100644 test/simple.rkt

diff --git a/lang/reader.rkt b/lang/reader.rkt
index 37ac7d7..e0ea1ef 100644
--- a/lang/reader.rkt
+++ b/lang/reader.rkt
@@ -4,94 +4,24 @@
                      [repltest-read-syntax read-syntax]
                      [repltest-get-info get-info]))
 
-(require syntax/module-reader
+(require (for-template repltest/private/run-interactions)
          racket/syntax
-         rackunit)
-
-(define (read-pre-prompt in)
-  (regexp-try-match #px"^\\s*" in))
-
-(define (read-actual-prompt in)
-  (regexp-try-match #px"^> " in))
-
-(define (peak-prompt in)
-  (regexp-try-match #px"^\\s*> " (peeking-input-port in)))
-
-(define (skip-newline in)
-  (regexp-try-match #px"^\n" in))
-
-(define (peek-read-length in)
-  (let* ([pk (peeking-input-port in)]
-         [start (file-position pk)]
-         [r (read pk)]
-         [end (file-position pk)])
-    (- end start)))
-
-(define (narrow-next-read in)
-  (make-limited-input-port in (peek-read-length in)))
-
-(define (peak-until-prompt-length in)
-  (let* ([pk (peeking-input-port in)]
-         [start (file-position pk)]
-         [end (let loop ()
-                (let* ([pre (read-pre-prompt pk)]
-                       [pos (file-position pk)]
-                       [pr (read-actual-prompt pk)])
-                  (if (or pr (eof-object? (read pk)))
-                      pos
-                      (loop))))])
-    (- end start)))
-
-(define (narrow-until-prompt in)
-  (make-limited-input-port in (peak-until-prompt-length in)))
-
-(define silent-prompt-read
-  (λ ()
-    ;; Default current-prompt-read, without showing
-    ;; the prompt
-    (let ([in ((current-get-interaction-input-port))])
-      ((current-read-interaction) (object-name in) in))))
-
-(define (run-interactions mod-stx in-rest)
-  (define/with-syntax (mod nm . body) mod-stx)
-  (let ([ns (make-base-namespace)])
-    (eval mod-stx ns)
-    ;; This is a hack because I can't get (module->namespace ''m) to work:
-    (define mod-ns (eval #'(begin (require racket/enter)
-                                  (enter! 'nm #:dont-re-require-enter)
-                                  (current-namespace))
-                         ns))
-    (let loop ()
-      (let* ([pr (read-actual-prompt in-rest)])
-        (when pr
-          (let* ([narrowed (narrow-next-read in-rest)]
-                 [os (open-output-string)]
-                 [actual (parameterize
-                             ([current-prompt-read
-                               silent-prompt-read]
-                              [current-get-interaction-input-port
-                               (λ () narrowed)]
-                              [current-namespace mod-ns]
-                              [current-output-port os]
-                              [current-error-port os]
-                              [current-print (λ (v)
-                                               (unless (void? v)
-                                                 (print v)
-                                                 (newline)))])
-                           (read-eval-print-loop)
-                           (get-output-string os))]
-                 [skip (skip-newline in-rest)]
-                 [expected (port->string (narrow-until-prompt in-rest))])
-            (check-equal? actual
-                          expected))
-          (loop))))))
+         repltest/private/util
+         (only-in syntax/module-reader make-meta-reader)
+         syntax/strip-context)
 
 (define ((wrap-reader reader) chr in src line col pos)
-  (define/with-syntax (mod nm . body)
+  (define/with-syntax (mod nm lang . body)
     (reader chr (narrow-until-prompt in) src line col pos))
-  ;; Run interactions:
-  (run-interactions #'(mod nm . body) in)
-  #'(mod nm . body))
+  #`(module nm racket
+      (module code lang . body)
+      (require 'code)
+      (provide (all-from-out 'code))
+      (module test racket/base
+        (require repltest/private/run-interactions)
+        (run-interactions #'(mod nm lang . body)
+                          (open-input-string #,(port->string in))
+                          (#%variable-reference)))))
 
 (define-values (repltest-read repltest-read-syntax repltest-get-info)
   (make-meta-reader
diff --git a/private/run-interactions.rkt b/private/run-interactions.rkt
new file mode 100644
index 0000000..e5af932
--- /dev/null
+++ b/private/run-interactions.rkt
@@ -0,0 +1,43 @@
+#lang racket/base
+
+(provide run-interactions)
+
+(require racket/syntax
+         racket/port
+         rackunit
+         repltest/private/util)
+
+(define (run-interactions mod-stx in-rest varref)
+  (define/with-syntax (mod nm lang . body) mod-stx)
+  (let ([ns (make-base-namespace)])
+    ;; This is a hack because I can't get (module->namespace ''nm) to work:
+    (define res-mod
+      (module-path-index-resolve
+       (module-path-index-join '(submod ".." code)
+                               (variable-reference->module-path-index varref))))
+    (dynamic-require res-mod #f)
+    (define mod-ns (module->namespace res-mod))
+    (let loop ()
+      (let* ([pr (read-actual-prompt in-rest)])
+        (when pr
+          (let* ([narrowed (narrow-next-read in-rest)]
+                 [os (open-output-string)]
+                 [actual (parameterize
+                             ([current-prompt-read
+                               silent-prompt-read]
+                              [current-get-interaction-input-port
+                               (λ () narrowed)]
+                              [current-namespace mod-ns]
+                              [current-output-port os]
+                              [current-error-port os]
+                              [current-print (λ (v)
+                                               (unless (void? v)
+                                                 (print v)
+                                                 (newline)))])
+                           (read-eval-print-loop)
+                           (get-output-string os))]
+                 [skip (skip-newline in-rest)]
+                 [expected (port->string (narrow-until-prompt in-rest))])
+            (check-equal? actual
+                          expected))
+          (loop))))))
\ No newline at end of file
diff --git a/private/util.rkt b/private/util.rkt
new file mode 100644
index 0000000..be0ec62
--- /dev/null
+++ b/private/util.rkt
@@ -0,0 +1,54 @@
+#lang racket/base
+
+(provide read-pre-prompt
+         read-actual-prompt
+         skip-newline
+         peek-read-length
+         narrow-next-read
+         peak-until-prompt-length
+         narrow-until-prompt
+         silent-prompt-read)
+
+(require racket/syntax
+         racket/port)
+
+(define (read-pre-prompt in)
+  (regexp-try-match #px"^\\s*" in))
+
+(define (read-actual-prompt in)
+  (regexp-try-match #px"^> " in))
+
+(define (skip-newline in)
+  (regexp-try-match #px"^\n" in))
+
+(define (peek-read-length in)
+  (let* ([pk (peeking-input-port in)]
+         [start (file-position pk)]
+         [r (read pk)]
+         [end (file-position pk)])
+    (- end start)))
+
+(define (narrow-next-read in)
+  (make-limited-input-port in (peek-read-length in)))
+
+(define (peak-until-prompt-length in)
+  (let* ([pk (peeking-input-port in)]
+         [start (file-position pk)]
+         [end (let loop ()
+                (let* ([pre (read-pre-prompt pk)]
+                       [pos (file-position pk)]
+                       [pr (read-actual-prompt pk)])
+                  (if (or pr (eof-object? (read pk)))
+                      pos
+                      (loop))))])
+    (- end start)))
+
+(define (narrow-until-prompt in)
+  (make-limited-input-port in (peak-until-prompt-length in)))
+
+(define silent-prompt-read
+  (λ ()
+    ;; Default current-prompt-read, without showing
+    ;; the prompt
+    (let ([in ((current-get-interaction-input-port))])
+      ((current-read-interaction) (object-name in) in))))
\ No newline at end of file
diff --git a/test/meta.rkt b/test/meta.rkt
new file mode 100644
index 0000000..e2b252e
--- /dev/null
+++ b/test/meta.rkt
@@ -0,0 +1,22 @@
+#lang debug repltest typed/racket
+;; There is a problem if there is a comment before a prompt, as comments aren't
+;; gobbled-up by the preceeding read.
+(define x 0)
+(define (y) #R(- 3 2))
+'displayed
+(displayln "displayed too")
+
+> (+ 1 1)
+- : Integer [more precisely: Positive-Index]
+2
+> x
+- : Integer [more precisely: Zero]
+0
+> (values x (y))
+(- 3 2) = 1
+- : (values Integer Integer) [more precisely: (Values Zero Fixnum)]
+0
+1
+> (+ 2 0)
+- : Integer [more precisely: Positive-Byte]
+2
diff --git a/test/simple.rkt b/test/simple.rkt
new file mode 100644
index 0000000..70920b0
--- /dev/null
+++ b/test/simple.rkt
@@ -0,0 +1,3 @@
+#lang repltest racket
+> (+ 1 1)
+2
diff --git a/test/test.rkt b/test/test.rkt
index 4a81816..0a692ca 100644
--- a/test/test.rkt
+++ b/test/test.rkt
@@ -1,22 +1,6 @@
-#lang debug repltest typed/racket
-;; There is a problem if there is a comment before a prompt, as comments aren't
-;; gobbled-up by the preceeding read.
+#lang repltest racket
+;; This file has the name "test", but it shouldn't cause any conflicts in module
+;; names
 (define x 0)
-(define y 1)
-'displayed
-(displayln "displayed too")
-
 > (+ 1 1)
-- : Integer [more precisely: Positive-Index]
-2
-> x
-- : Integer [more precisely: Zero]
-0
-> (values x y)
-- : (values Integer Integer) [more precisely: (Values Zero One)]
-0
-1
-> #R(+ 2 0)
-(+ 2 0) = 2
-- : Integer [more precisely: Positive-Byte]
 2