commit 5488f1da5bff6de64c529bbd9550431f8d74523a
parent 220b23630cb03cfe92407d547bc6a5c0e5ff7df7
Author: Georges Dupéron <georges.duperon@gmail.com>
Date: Thu, 31 Mar 2016 00:17:29 +0200
Fixes GitHub issue #4. Needs cleanup.
Diffstat:
5 files changed, 145 insertions(+), 46 deletions(-)
diff --git a/lang/reader.rkt b/lang/reader.rkt
@@ -5,6 +5,7 @@
[repltest-get-info get-info]))
(require (for-template repltest/private/run-interactions)
+ (for-template repltest/private/modbg)
racket/syntax
repltest/private/util
(only-in syntax/module-reader make-meta-reader)
@@ -13,15 +14,56 @@
(define ((wrap-reader reader) chr in src line col pos)
(define/with-syntax (mod nm lang . body)
(reader chr (narrow-until-prompt in) src line col pos))
- #`(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)))))
+ ;(displayln "WARNING: skipping tests")(port->string in) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;DEBUG
+
+ (with-syntax ([(m1 n1 l1 (mb1 . bd1))
+ (eval #'(expand #`(mod nm lang . body))
+ (variable-reference->namespace (#%variable-reference)))])
+ #`(m1 n1 l1
+ (mb1 (module* test racket/base
+ (require repltest/private/run-interactions)
+ (run-interactions ;#'(mod nm lang . body)
+ (open-input-string #,(port->string in))
+ (#%variable-reference)))
+ . bd1)))
+
+ ;#`(mod nm lang . body)
+ #;#`(mod nm repltest/private/modbg
+ require
+ (module nm lang (require lang) . body)
+ #;#,(port->string in)
+ (module* test racket/base
+ (require repltest/private/run-interactions)
+ (run-interactions ;#'(mod nm lang . body)
+ (open-input-string #,(port->string in))
+ (#%variable-reference)))))
+#|
+ #;(insert-in-module
+ (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/with-syntax (mod2 nm2 lang2 (modbeg2 . body2))
+ (local-expand #'(module nm lang . body)
+ 'module
+ '()))
+ #;((λ (x)
+ (displayln x)
+ x)
+ #`(mod2 nm2 lang2
+ (modbeg2
+ #;(module test racket/base
+ (require repltest/private/run-interactions)
+ (run-interactions #'(mod nm lang . body)
+ (open-input-string #,(port->string in))
+ (#%variable-reference)))
+ . body2)))
+ |#
(define-values (repltest-read repltest-read-syntax repltest-get-info)
(make-meta-reader
diff --git a/private/modbg.rkt b/private/modbg.rkt
@@ -0,0 +1,54 @@
+#lang racket/base
+
+(provide (rename-out [insert-in-module #%module-begin]))
+
+(require (for-syntax racket/base
+ syntax/strip-context))
+
+(define-syntax (insert-in-module stx)
+ (syntax-case stx ()
+ [(_ rr
+ (mod1 nm1 lang1 (req lng) . bdy1);orig-mod
+ submod
+ ;str
+ )
+ (with-syntax ([(mod nm lang (modbg . body)) (expand ;#'orig-mod
+ #'(mod1 nm1 lang1 . bdy1))])
+ ;(with-syntax ([req (datum->syntax #'md1 'require)])
+
+
+ ((λ (x)
+ (displayln x)
+ x)
+ (syntax-local-introduce
+ #`(modbg ;(require lang)
+ ;(req #,(datum->syntax #'req (syntax->datum #'lang)))
+ ;(rr lang)
+ . body)))
+
+ #;#`(modbg ;(require lang)
+ ;; ok for #%top-interaction:
+ (req #,(datum->syntax #'req (syntax->datum #'lang)))
+ ;; not ok for #%top-interaction:
+ ;(req lang)
+ (rr lang)
+ (define varref (#,(datum->syntax #'lang '#%variable-reference)))
+ (provide varref)
+ submod
+ #;(module* test racket/base
+ (require repltest/private/run-interactions)
+ (require (submod ".."))
+ #;(define res-mod
+ (module-path-index-resolve
+ (module-path-index-join '(submod "..")
+ (variable-reference->module-path-index
+ varref))))
+ ;(define mod-ns (module->namespace res-mod))
+ (define mod-ns (variable-reference->namespace varref))
+ (displayln mod-ns)
+ (run-interactions2 (open-input-string str)
+ mod-ns)
+ #;(run-interactions (open-input-string str)
+ #,(datum->syntax #'modbg '#%variable-reference)
+ #;(#%variable-reference)))
+ . body))]))
+\ No newline at end of file
diff --git a/private/run-interactions.rkt b/private/run-interactions.rkt
@@ -1,43 +1,44 @@
#lang racket/base
-(provide run-interactions)
+(provide run-interactions
+ run-interactions2)
(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
+(define (run-interactions in-rest varref)
+ (define res-mod
+ (module-path-index-resolve
+ (module-path-index-join '(submod "..")
+ (variable-reference->module-path-index varref))))
+ (dynamic-require res-mod #f)
+ (define mod-ns (module->namespace res-mod))
+ (run-interactions2 in-rest mod-ns))
+
+(define (run-interactions2 in-rest mod-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)))))
+\ No newline at end of file
diff --git a/test/meta.rkt b/test/meta.rkt
@@ -1,4 +1,5 @@
#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)
diff --git a/test/test.rkt b/test/test.rkt
@@ -1,4 +1,4 @@
-#lang repltest racket
+#lang repltest typed/racket
;; This file has the name "test", but it shouldn't cause any conflicts in module
;; names
(define x 0)
