From 8217dddd568e2193182a2c3857d9691ea2127606 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Tue, 7 Oct 2008 10:56:29 +0000 Subject: [PATCH] * The module-path place is now optional, and #:language can be used with an expression (evaluated as usual, not quoted), or with a thunk that is invoked before reading the body begins. * Added some missing tests that were not used for some reason... * Some other documentation improvements. * Improved the code a little more. svn: r11957 --- collects/syntax/module-reader.ss | 80 +++++++++++-------- .../syntax/scribblings/module-reader.scrbl | 43 +++++++--- collects/tests/mzscheme/module-reader.ss | 29 ++++++- 3 files changed, 103 insertions(+), 49 deletions(-) diff --git a/collects/syntax/module-reader.ss b/collects/syntax/module-reader.ss index 4b6cc36f86..1fbeea1651 100644 --- a/collects/syntax/module-reader.ss +++ b/collects/syntax/module-reader.ss @@ -7,70 +7,81 @@ (require (for-syntax scheme/base)) (define-syntax (provide-module-reader stx) - (define (construct-reader lib body) - (define (err str [sub #f]) - (raise-syntax-error 'syntax/module-reader str sub)) - (define-syntax-rule (keywords -body [kwd var default] ... [checks ...]) - (begin - (define var #f) ... - (define -body - (let loop ([body body]) - (if (not (and (pair? body) - (pair? (cdr body)) - (keyword? (syntax-e (car body))))) - (datum->syntax stx body stx) - (let* ([k (car body)] [k* (syntax-e k)] [v (cadr body)]) - (case k* - [(kwd) (if var - (err (format "got two ~s keywords" k*) k) - (begin (set! var v) (loop (cddr body))))] - ... - [else (err "got an unknown keyword" (car body))]))))) - checks ... - (set! var (or var default)) ...)) - (keywords -body + (define (err str [sub #f]) + (raise-syntax-error 'syntax/module-reader str sub)) + (define-syntax-rule (keywords body [kwd var default] ... [checks ...]) + (begin + (define var #f) ... + (set! body + (let loop ([body body]) + (if (not (and (pair? body) + (pair? (cdr body)) + (keyword? (syntax-e (car body))))) + (datum->syntax stx body stx) + (let* ([k (car body)] [k* (syntax-e k)] [v (cadr body)]) + (case k* + [(kwd) (if var + (err (format "got two ~s keywords" k*) k) + (begin (set! var v) (loop (cddr body))))] + ... + [else (err "got an unknown keyword" (car body))]))))) + checks ... + (set! var (or var default)) ...)) + (define (construct-reader lang body) + (keywords body + [#:language ~lang lang] [#:read ~read #'read] [#:read-syntax ~read-syntax #'read-syntax] [#:wrapper1 ~wrapper1 #'#f] [#:wrapper2 ~wrapper2 #'#f] [#:whole-body-readers? ~whole-body-readers? #'#f] - [(unless (equal? (and ~read #t) (and ~read-syntax #t)) + [(when (equal? (and lang #t) (and ~lang #t)) + (err (string-append "must specify either a module path, or #:lang" + (if (and lang ~lang) ", not both" "")))) + (unless (equal? (and ~read #t) (and ~read-syntax #t)) (err "must specify either both #:read and #:read-syntax, or none")) (when (and ~whole-body-readers? (not (and ~read ~read-syntax))) (err "got a #:whole-body-readers? without #:read and #:read-syntax"))]) (quasisyntax/loc stx (#%module-begin - #,@-body + #,@body (#%provide (rename *read read) (rename *read-syntax read-syntax)) (define-values (*read *read-syntax) - (let* ([rd #,~read] + (let* ([lang #,~lang] + [rd #,~read] [rds #,~read-syntax] [w1 #,~wrapper1] [w2 #,~wrapper2] [w2 (cond [(not w2) (lambda (in r _) (r in))] [(procedure-arity-includes? w2 3) w2] [else (lambda (in r _) (w2 in r))])] - [base '#,lib] [whole? #,~whole-body-readers?]) (values (lambda (in modpath line col pos) (w2 in (lambda (in) - (wrap-internal base in rd whole? + (wrap-internal lang in rd whole? w1 #f modpath #f line col pos)) #f)) (lambda (src in modpath line col pos) (w2 in (lambda (in) - (wrap-internal base in (lambda (in) (rds src in)) whole? + (wrap-internal lang in (lambda (in) (rds src in)) whole? w1 #t modpath src line col pos)) #t)))))))) (syntax-case stx () - [(_ lib body ...) (construct-reader #'lib (syntax->list #'(body ...)))])) + [(_ lang body ...) + (not (keyword? (syntax-e #'lang))) + (construct-reader #''lang (syntax->list #'(body ...)))] + [(_ body ...) (construct-reader #f (syntax->list #'(body ...)))])) -(define (wrap-internal lib port read whole? wrapper stx? +(define (wrap-internal lang port read whole? wrapper stx? modpath src line col pos) - (let* ([body (lambda () + (let* ([lang (if (procedure? lang) + (parameterize ([current-input-port port]) (lang)) + lang)] + [lang (if stx? (datum->syntax #f lang modpath modpath) lang)] + [body (lambda () (if whole? (read port) (let loop ([a null]) @@ -98,11 +109,10 @@ (- (or (syntax-position modpath) (add1 pos)) pos))) v))] - [lib (if stx? (datum->syntax #f lib modpath modpath) lib)] - [r `(,(tag-src 'module) ,(tag-src name) ,lib . ,body)]) + [r `(,(tag-src 'module) ,(tag-src name) ,lang . ,body)]) (if stx? (datum->syntax #f r all-loc) r))) -(define (wrap lib port read modpath src line col pos) - (wrap-internal lib port read #f #f #f modpath src line col pos)) +(define (wrap lang port read modpath src line col pos) + (wrap-internal lang port read #f #f #f modpath src line col pos)) ) diff --git a/collects/syntax/scribblings/module-reader.scrbl b/collects/syntax/scribblings/module-reader.scrbl index 0df8ded4f1..d867e05546 100644 --- a/collects/syntax/scribblings/module-reader.scrbl +++ b/collects/syntax/scribblings/module-reader.scrbl @@ -16,8 +16,10 @@ of read modules; using keywords, the resulting readers can be customized in a number of ways. @defform*/subs[[(#%module-begin module-path) - (#%module-begin module-path reader-option ... body ....)] - ([reader-option (code:line #:read read-expr) + (#%module-begin module-path reader-option ... body ....) + (#%module-begin reader-option ... body ....)] + ([reader-option (code:line #:language lang-expr) + (code:line #:read read-expr) (code:line #:read-syntax read-syntax-expr) (code:line #:wrapper1 wrapper1-expr) (code:line #:wrapper2 wrapper2-expr) @@ -77,7 +79,7 @@ For example, here is a case-insensitive reader for the @scheme[scheme/base] language: @schemeblock[ -(module insensitive syntax/module-reader +(module reader syntax/module-reader scheme/base #:read (wrap read) #:read-syntax (wrap read-syntax) (define ((wrap reader) . args) @@ -94,7 +96,7 @@ alternative definition of the case-insensitive language using @scheme[#:wrapper1]: @schemeblock[ -(module insensitive syntax/module-reader +(module reader syntax/module-reader scheme/base #:wrapper1 (lambda (t) (parameterize ([read-case-sensitive #f]) @@ -102,7 +104,7 @@ alternative definition of the case-insensitive language using ] Note that using a @tech[#:doc refman]{readtable}, you can implement -languages that go beyond plain S-expressions. +languages that are extensions of plain S-expressions. In addition to this wrapper, there is also @scheme[#:wrapper2] that has more control over the resulting reader functions. If specified, @@ -114,7 +116,7 @@ that corresponds to a file). Here is the case-insensitive implemented using this option: @schemeblock[ -(module insensitive syntax/module-reader +(module reader syntax/module-reader scheme/base #:wrapper2 (lambda (in r) (parameterize ([read-case-sensitive #f]) @@ -122,14 +124,14 @@ using this option: ] In some cases, the reader functions read the whole file, so there is -no need to iterate them (e.g., @scheme[read-inside] and +no need to iterate them (e.g., Scribble's @scheme[read-inside] and @scheme[read-syntax-inside]). In these cases you can specify @scheme[#:whole-body-readers?] as @scheme[#t] --- the readers are expected to return a list of expressions in this case. -Finally, note that the two wrappers can return a different value than -the wrapped function. This introduces two more customization points -for the resulting readers: +In addition, the two wrappers can return a different value than the +wrapped function. This introduces two more customization points for +the resulting readers: @itemize{ @item{The thunk that is passed to a @scheme[#:wrapper1] function reads the file contents and returns a list of read expressions @@ -157,7 +159,7 @@ scribble syntax, and the first datum in the file determines the actual language (which means that the library specification is effectively ignored): @schemeblock[ -(module scribbled syntax/module-reader +(module reader syntax/module-reader -ignored- #:wrapper2 (lambda (in rd stx?) @@ -173,6 +175,25 @@ ignored): (if stx? r (syntax->datum r)))) (require scribble/reader)) ] + +This ability to change the language position in the resulting module +expression can be useful in cases such as the above, where the base +language module is chosen based on the input. To make this more +convenient, you can omit the @scheme[module-path] and instead specify +it via a @scheme[#:language] expression. This expression can evaluate +to a datum which is used as a language, or it can evaluate to a thunk. +In the latter case, the thunk will be invoked to return such a datum +before reading the module body begins, in a dynamic extent where +@scheme[current-input-port] is the source input. Using this, the last +example above can be written more concisely: +@schemeblock[ +(module reader syntax/module-reader + #:language read + #:wrapper2 (lambda (in rd stx?) + (parameterize ([current-readtable (make-at-readtable)]) + (rd in))) + (require scribble/reader)) +] } @defproc[(wrap-read-all [mod-path module-path?] diff --git a/collects/tests/mzscheme/module-reader.ss b/collects/tests/mzscheme/module-reader.ss index 4a7a190bdb..3d754da885 100644 --- a/collects/tests/mzscheme/module-reader.ss +++ b/collects/tests/mzscheme/module-reader.ss @@ -43,8 +43,13 @@ #:wrapper2 (lambda (in rd) (if (syntax? (rd in)) #'(module page zzz) '(module page zzz)))) +;; the same, the easy way +(module r9 syntax/module-reader + #:language (lambda () 'zzz) + #:wrapper1 (lambda (t) '())) + ;; a module that uses the scribble syntax with a specified language -(module r9 syntax/module-reader -ignored- +(module r10 syntax/module-reader -ignored- #:wrapper2 (lambda (in rd stx?) (let* ([lang (read in)] @@ -59,6 +64,14 @@ (if stx? r (syntax->datum r)))) (require scribble/reader)) +;; the same, using #:language +(module r11 syntax/module-reader + #:language read + #:wrapper2 (lambda (in rd stx?) + (parameterize ([current-readtable (make-at-readtable)]) + (rd in))) + (require scribble/reader)) + (define (from-string read str) (parameterize ([read-accept-reader #t]) (read (open-input-string str)))) @@ -83,10 +96,20 @@ (test-both "#reader 'r6 (define foo #:bar)" '(module page zzz)) +(test-both "#reader 'r7 (define foo #:bar)" + '(module page zzz)) +(test-both "#reader 'r8 (define foo #:bar)" + '(module page zzz)) +(test-both "#reader 'r9 (define foo #:bar)" + '(module page zzz)) -(test-both "#reader 'r9 scheme/base (define foo 1)" +(test-both "#reader 'r10 scheme/base (define foo 1)" '(module page scheme/base (define foo 1))) -(test-both "#reader 'r9 scheme/base @define[foo]{one}" +(test-both "#reader 'r10 scheme/base @define[foo]{one}" + '(module page scheme/base (define foo "one"))) +(test-both "#reader 'r11 scheme/base (define foo 1)" + '(module page scheme/base (define foo 1))) +(test-both "#reader 'r11 scheme/base @define[foo]{one}" '(module page scheme/base (define foo "one"))) ;; ----------------------------------------