* 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
This commit is contained in:
Eli Barzilay
parent
da389b03a9
commit
8217dddd56
|
|
@ -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))
|
||||
|
||||
)
|
||||
|
|
|
|||
|
|
@ -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?]
|
||||
|
|
|
|||
|
|
@ -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")))
|
||||
|
||||
;; ----------------------------------------
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user