commit 220b23630cb03cfe92407d547bc6a5c0e5ff7df7
parent 7b3b27cf0f02a2bb3409657572919be21226c62f
Author: Georges Dupéron <georges.duperon@gmail.com>
Date: Wed, 30 Mar 2016 19:35:54 +0200
Fixes GH issue #2 and #3
Diffstat:
6 files changed, 141 insertions(+), 103 deletions(-)
diff --git 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
@@ -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
@@ -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
@@ -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
@@ -0,0 +1,3 @@
+#lang repltest racket
+> (+ 1 1)
+2
diff --git 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
