From 5488f1da5bff6de64c529bbd9550431f8d74523a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= Date: Thu, 31 Mar 2016 00:17:29 +0200 Subject: [PATCH] Fixes GitHub issue #4. Needs cleanup. --- lang/reader.rkt | 60 +++++++++++++++++++++++++----- private/modbg.rkt | 54 +++++++++++++++++++++++++++ private/run-interactions.rkt | 71 ++++++++++++++++++------------------ test/meta.rkt | 1 + test/test.rkt | 2 +- 5 files changed, 143 insertions(+), 45 deletions(-) create mode 100644 private/modbg.rkt diff --git a/lang/reader.rkt b/lang/reader.rkt index e0ea1ef..a83a1aa 100644 --- 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 new file mode 100644 index 0000000..aca1794 --- /dev/null +++ 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 index e5af932..5e481d0 100644 --- 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 index e2b252e..0de4fa5 100644 --- 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 index 0a692ca..0cbd23f 100644 --- 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)