suzanne.soy/repltest
1
0
Fork 0
Code Issues 11 Pull Requests Actions Packages Projects Releases Wiki Activity

Fixes GitHub issue #4. Needs cleanup.

Browse Source
This commit is contained in:
Georges Dupéron 2016-03-31 00:17:29 +02:00
parent 220b23630c
commit 5488f1da5b
5 changed files with 143 additions and 45 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

60
lang/reader.rkt
View File

@ -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

54
private/modbg.rkt Normal file
View File

@ -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))]))

71
private/run-interactions.rkt
View File

@ -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))))))
(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)))))

1
test/meta.rkt
View File

@ -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)

2
test/test.rkt
View File

@ -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)