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

* The module-path place is now optional, and #:language can be used

Browse Source 
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
This commit is contained in:
Eli Barzilay 2008-10-07 10:56:29 +00:00
parent da389b03a9
commit 8217dddd56
3 changed files with 103 additions and 49 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

80
collects/syntax/module-reader.ss
View File

@ -7,70 +7,81 @@
(require (for-syntax scheme/base)) (require (for-syntax scheme/base))
(define-syntax (provide-module-reader stx) (define-syntax (provide-module-reader stx)
(define (construct-reader lib body) (define (err str [sub #f])
(define (err str [sub #f]) (raise-syntax-error 'syntax/module-reader str sub))
(raise-syntax-error 'syntax/module-reader str sub)) (define-syntax-rule (keywords body [kwd var default] ... [checks ...])
(define-syntax-rule (keywords -body [kwd var default] ... [checks ...]) (begin
(begin (define var #f) ...
(define var #f) ... (set! body
(define -body (let loop ([body body])
(let loop ([body body]) (if (not (and (pair? body)
(if (not (and (pair? body) (pair? (cdr body))
(pair? (cdr body)) (keyword? (syntax-e (car body)))))
(keyword? (syntax-e (car body))))) (datum->syntax stx body stx)
(datum->syntax stx body stx) (let* ([k (car body)] [k* (syntax-e k)] [v (cadr body)])
(let* ([k (car body)] [k* (syntax-e k)] [v (cadr body)]) (case k*
(case k* [(kwd) (if var
[(kwd) (if var (err (format "got two ~s keywords" k*) k)
(err (format "got two ~s keywords" k*) k) (begin (set! var v) (loop (cddr body))))]
(begin (set! var v) (loop (cddr body))))] ...
... [else (err "got an unknown keyword" (car body))])))))
[else (err "got an unknown keyword" (car body))]))))) checks ...
checks ... (set! var (or var default)) ...))
(set! var (or var default)) ...)) (define (construct-reader lang body)
(keywords -body (keywords body
[#:language ~lang lang]
[#:read ~read #'read] [#:read ~read #'read]
[#:read-syntax ~read-syntax #'read-syntax] [#:read-syntax ~read-syntax #'read-syntax]
[#:wrapper1 ~wrapper1 #'#f] [#:wrapper1 ~wrapper1 #'#f]
[#:wrapper2 ~wrapper2 #'#f] [#:wrapper2 ~wrapper2 #'#f]
[#:whole-body-readers? ~whole-body-readers? #'#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")) (err "must specify either both #:read and #:read-syntax, or none"))
(when (and ~whole-body-readers? (not (and ~read ~read-syntax))) (when (and ~whole-body-readers? (not (and ~read ~read-syntax)))
(err "got a #:whole-body-readers? without #:read and #:read-syntax"))]) (err "got a #:whole-body-readers? without #:read and #:read-syntax"))])
(quasisyntax/loc stx (quasisyntax/loc stx
(#%module-begin (#%module-begin
#,@-body #,@body
(#%provide (rename *read read) (rename *read-syntax read-syntax)) (#%provide (rename *read read) (rename *read-syntax read-syntax))
(define-values (*read *read-syntax) (define-values (*read *read-syntax)
(let* ([rd #,~read] (let* ([lang #,~lang]
[rd #,~read]
[rds #,~read-syntax] [rds #,~read-syntax]
[w1 #,~wrapper1] [w1 #,~wrapper1]
[w2 #,~wrapper2] [w2 #,~wrapper2]
[w2 (cond [(not w2) (lambda (in r _) (r in))] [w2 (cond [(not w2) (lambda (in r _) (r in))]
[(procedure-arity-includes? w2 3) w2] [(procedure-arity-includes? w2 3) w2]
[else (lambda (in r _) (w2 in r))])] [else (lambda (in r _) (w2 in r))])]
[base '#,lib]
[whole? #,~whole-body-readers?]) [whole? #,~whole-body-readers?])
(values (values
(lambda (in modpath line col pos) (lambda (in modpath line col pos)
(w2 in (w2 in
(lambda (in) (lambda (in)
(wrap-internal base in rd whole? (wrap-internal lang in rd whole?
w1 #f modpath #f line col pos)) w1 #f modpath #f line col pos))
#f)) #f))
(lambda (src in modpath line col pos) (lambda (src in modpath line col pos)
(w2 in (w2 in
(lambda (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)) w1 #t modpath src line col pos))
#t)))))))) #t))))))))
(syntax-case stx () (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) 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? (if whole?
(read port) (read port)
(let loop ([a null]) (let loop ([a null])
@ -98,11 +109,10 @@
(- (or (syntax-position modpath) (add1 pos)) (- (or (syntax-position modpath) (add1 pos))
pos))) pos)))
v))] v))]
[lib (if stx? (datum->syntax #f lib modpath modpath) lib)] [r `(,(tag-src 'module) ,(tag-src name) ,lang . ,body)])
[r `(,(tag-src 'module) ,(tag-src name) ,lib . ,body)])
(if stx? (datum->syntax #f r all-loc) r))) (if stx? (datum->syntax #f r all-loc) r)))
(define (wrap lib port read modpath src line col pos) (define (wrap lang port read modpath src line col pos)
(wrap-internal lib port read #f #f #f modpath src line col pos)) (wrap-internal lang port read #f #f #f modpath src line col pos))
) )

43
collects/syntax/scribblings/module-reader.scrbl
View File

@ -16,8 +16,10 @@ of read modules; using keywords, the resulting readers can be
customized in a number of ways. customized in a number of ways.
@defform*/subs[[(#%module-begin module-path) @defform*/subs[[(#%module-begin module-path)
(#%module-begin module-path reader-option ... body ....)] (#%module-begin module-path reader-option ... body ....)
([reader-option (code:line #:read read-expr) (#%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 #:read-syntax read-syntax-expr)
(code:line #:wrapper1 wrapper1-expr) (code:line #:wrapper1 wrapper1-expr)
(code:line #:wrapper2 wrapper2-expr) (code:line #:wrapper2 wrapper2-expr)
@ -77,7 +79,7 @@ For example, here is a case-insensitive reader for the
@scheme[scheme/base] language: @scheme[scheme/base] language:
@schemeblock[ @schemeblock[
(module insensitive syntax/module-reader (module reader syntax/module-reader
scheme/base scheme/base
#:read (wrap read) #:read-syntax (wrap read-syntax) #:read (wrap read) #:read-syntax (wrap read-syntax)
(define ((wrap reader) . args) (define ((wrap reader) . args)
@ -94,7 +96,7 @@ alternative definition of the case-insensitive language using
@scheme[#:wrapper1]: @scheme[#:wrapper1]:
@schemeblock[ @schemeblock[
(module insensitive syntax/module-reader (module reader syntax/module-reader
scheme/base scheme/base
#:wrapper1 (lambda (t) #:wrapper1 (lambda (t)
(parameterize ([read-case-sensitive #f]) (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 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 In addition to this wrapper, there is also @scheme[#:wrapper2] that
has more control over the resulting reader functions. If specified, 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: using this option:
@schemeblock[ @schemeblock[
(module insensitive syntax/module-reader (module reader syntax/module-reader
scheme/base scheme/base
#:wrapper2 (lambda (in r) #:wrapper2 (lambda (in r)
(parameterize ([read-case-sensitive #f]) (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 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[read-syntax-inside]). In these cases you can specify
@scheme[#:whole-body-readers?] as @scheme[#t] --- the readers are @scheme[#:whole-body-readers?] as @scheme[#t] --- the readers are
expected to return a list of expressions in this case. expected to return a list of expressions in this case.
Finally, note that the two wrappers can return a different value than In addition, the two wrappers can return a different value than the
the wrapped function. This introduces two more customization points wrapped function. This introduces two more customization points for
for the resulting readers: the resulting readers:
@itemize{ @itemize{
@item{The thunk that is passed to a @scheme[#:wrapper1] function @item{The thunk that is passed to a @scheme[#:wrapper1] function
reads the file contents and returns a list of read expressions 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 language (which means that the library specification is effectively
ignored): ignored):
@schemeblock[ @schemeblock[
(module scribbled syntax/module-reader (module reader syntax/module-reader
-ignored- -ignored-
#:wrapper2 #:wrapper2
(lambda (in rd stx?) (lambda (in rd stx?)
@ -173,6 +175,25 @@ ignored):
(if stx? r (syntax->datum r)))) (if stx? r (syntax->datum r))))
(require scribble/reader)) (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?] @defproc[(wrap-read-all [mod-path module-path?]

29
collects/tests/mzscheme/module-reader.ss
View File

@ -43,8 +43,13 @@
#:wrapper2 (lambda (in rd) #:wrapper2 (lambda (in rd)
(if (syntax? (rd in)) #'(module page zzz) '(module page zzz)))) (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 ;; a module that uses the scribble syntax with a specified language
(module r9 syntax/module-reader -ignored- (module r10 syntax/module-reader -ignored-
#:wrapper2 #:wrapper2
(lambda (in rd stx?) (lambda (in rd stx?)
(let* ([lang (read in)] (let* ([lang (read in)]
@ -59,6 +64,14 @@
(if stx? r (syntax->datum r)))) (if stx? r (syntax->datum r))))
(require scribble/reader)) (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) (define (from-string read str)
(parameterize ([read-accept-reader #t]) (parameterize ([read-accept-reader #t])
(read (open-input-string str)))) (read (open-input-string str))))
@ -83,10 +96,20 @@
(test-both "#reader 'r6 (define foo #:bar)" (test-both "#reader 'r6 (define foo #:bar)"
'(module page zzz)) '(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))) '(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"))) '(module page scheme/base (define foo "one")))
;; ---------------------------------------- ;; ----------------------------------------