commit e930471f52c206fe2bbcbc01638ccc0da7a55582
parent 432bc0742d500fc4fe479b85967f548da491f0a5
Author: Georges Dupéron <georges.duperon@gmail.com>
Date: Wed, 17 Aug 2016 21:29:10 +0200
Circumvented raco cover issue with eval and fixed srcloc for reader-injected code, as suggested by Spencer Florence https://github.com/florence/cover/issues/128#issuecomment-240503899
Diffstat:
| M | lang/reader.rkt | | | 62 | +++++++++++++++++++++++++++++++++++++++++++++++++++----------- |
| M | main.rkt | | | 22 | ---------------------- |
2 files changed, 51 insertions(+), 33 deletions(-)
diff --git a/lang/reader.rkt b/lang/reader.rkt
@@ -10,21 +10,61 @@
(only-in syntax/module-reader make-meta-reader)
syntax/strip-context)
+;; Replaces the syntax/loc for the top of the syntax object, until
+;; a part which doesn't belong to old-source is reached.
+;; e.g. (with-syntax ([d user-provided-syntax])
+;; (replace-top-loc
+;; #'(a b (c d e))
+;; (syntax-source #'here)
+;; new-loc))
+;; will produce a syntax object #'(a b (c (x (y) z) e))
+;; where a, b, c, z, e and their surrounding forms have their srcloc set to
+;; new-loc, but (x (y) z) will be left intact, if the user-provided-syntax
+;; appears in another file.
+(define (replace-top-loc stx old-source new-loc)
+ (let process ([stx stx])
+ (cond
+ [(syntax? stx)
+ (if (equal? (syntax-source stx) old-source)
+ (datum->syntax stx (process (syntax-e stx)) new-loc stx)
+ stx
+ ;; Use the following expression to replace the loc throughout stx
+ ;; instead of stopping the depth-first-search when the syntax-source
+ ;; is not old-source anymore
+ #;(datum->syntax stx (process (syntax-e stx)) stx stx))]
+ [(pair? stx)
+ (cons (process (car stx))
+ (process (cdr stx)))]
+ [(vector? stx)
+ (list->vector (process (vector->list stx)))]
+ [(prefab-struct-key stx)
+ => (λ (key)
+ (make-prefab-struct key
+ (process (struct->vector stx))))]
+ [else
+ stx])))
+
(define ((wrap-reader reader) chr in src line col pos)
(define/with-syntax orig-mod
(reader chr (narrow-until-prompt in) src line col pos))
- (with-syntax ([(mod nam lang (modbeg . body))
- (eval #'(expand #'orig-mod)
- (variable-reference->namespace (#%variable-reference)))])
- #`(mod nam lang
- (modbeg
- (module code racket/base)
- (module* test racket/base
- (require repltest/private/run-interactions)
- (run-interactions (open-input-string #,(port->string in))
- (#%variable-reference)))
- . body))))
+ (define/with-syntax (mod nam lang (modbeg . body))
+ (parameterize ([current-namespace (variable-reference->namespace
+ (#%variable-reference))])
+ (expand #'orig-mod)))
+ ;; quasisyntax/loc Necessary so that the generated code has the correct srcloc
+ (replace-top-loc
+ #`(mod nam lang
+ (modbeg
+ ;(quote-syntax orig-mod)
+ (module* test racket/base
+ (require repltest/private/run-interactions)
+ ;; TODO: set-port-next-location! for (open-input-string …)
+ (run-interactions (open-input-string #,(port->string in))
+ (#%variable-reference)))
+ . body))
+ (syntax-source #'here)
+ #'mod))
(define-values (repltest-read repltest-read-syntax repltest-get-info)
(make-meta-reader
diff --git a/main.rkt b/main.rkt
@@ -1,25 +1,3 @@
#lang racket/base
;; This package is a meta-language, and currently provides no bindings.
-
-;; Notice
-;; To install (from within the package directory):
-;; $ raco pkg install
-;; To install (once uploaded to pkgs.racket-lang.org):
-;; $ raco pkg install <<name>>
-;; To uninstall:
-;; $ raco pkg remove <<name>>
-;; To view documentation:
-;; $ raco doc <<name>>
-;;
-;; For your convenience, we have included a LICENSE.txt file, which links to
-;; the GNU Lesser General Public License.
-;; If you would prefer to use a different license, replace LICENSE.txt with the
-;; desired license.
-;;
-;; Some users like to add a `private/` directory, place auxiliary files there,
-;; and require them in `main.rkt`.
-;;
-;; See the current version of the racket style guide here:
-;; http://docs.racket-lang.org/style/index.html
-
