diff --git a/collects/scribble/doc/reader.ss b/collects/scribble/doc/reader.ss index 2e9c33423d..ddc616132e 100644 --- a/collects/scribble/doc/reader.ss +++ b/collects/scribble/doc/reader.ss @@ -2,22 +2,9 @@ scribble/doclang -;; `read-inside' reads the whole body, so make wrapper1 return null so -;; we get the right syntax, and then make wrapper2 do the actual -;; reading. This might seem extreme, but I think that it's still -;; better to use module-reader for the subtleties it deals with. - -#:wrapper1 (lambda (t) '()) - -#:wrapper2 -(lambda (in read stx?) - (let* ([skeleton (read in)] - [skeleton (if stx? (syntax->list skeleton) skeleton)] - [body (if stx? - (scribble:read-syntax-inside (object-name in) in) - (scribble:read-inside in))] - [mod `(,(car skeleton) ,(cadr skeleton) ,(caddr skeleton) - (#%module-begin doc () . ,body))]) - (if stx? (datum->syntax #f mod) mod))) +#:read scribble:read-inside +#:read-syntax scribble:read-syntax-inside +#:whole-body-readers? #t +#:wrapper1 (lambda (t) (list* 'doc '() (t))) (require (prefix-in scribble: "../reader.ss")) diff --git a/collects/syntax/module-reader.ss b/collects/syntax/module-reader.ss index 37630bd92e..824bc7d38e 100644 --- a/collects/syntax/module-reader.ss +++ b/collects/syntax/module-reader.ss @@ -9,72 +9,68 @@ (define-syntax (provide-module-reader stx) (syntax-case stx () [(_ lib body ...) - (let ([-read #f] - [-read-syntax #f] - [-wrapper1 #f] - [-wrapper2 #f]) + (let ([key-args '()]) + (define (err str [sub #f]) + (raise-syntax-error 'syntax/module-reader str sub)) (define -body - (let loop ([body #'(body ...)]) - (define (err str) - (raise-syntax-error 'syntax/module-reader str - (car (syntax->list body)))) - (syntax-case body () - [(#:read r body ...) - (if -read - (err "got two #:read keywords") - (begin (set! -read #'r) (loop #'(body ...))))] - [(#:read-syntax r body ...) - (if -read-syntax - (err "got two #:read-syntax keywords") - (begin (set! -read-syntax #'r) (loop #'(body ...))))] - [(#:wrapper1 w body ...) - (if -wrapper1 - (err "got two #:wrapper1 keywords") - (begin (set! -wrapper1 #'w) (loop #'(body ...))))] - [(#:wrapper2 w body ...) - (if -wrapper2 - (err "got two #:wrapper2 keywords") - (begin (set! -wrapper2 #'w) (loop #'(body ...))))] - [(k . b) (keyword? (syntax-e #'k)) - (err "got an unknown keyword")] - [_ body]))) - (with-syntax ([-read (or -read #'read)] - [-read-syntax (or -read-syntax #'read-syntax)] - [-wrapper1 (or -wrapper1 #'#f)] - [-wrapper2 (or -wrapper2 #'#f)] - [(body ...) -body]) - (syntax/loc stx - (#%module-begin - body ... - (#%provide (rename *read read) (rename *read-syntax read-syntax)) - (define-values (*read *read-syntax) - (let ([rd -read] - [rds -read-syntax] - [w1 -wrapper1] - [w2 (let ([w -wrapper2]) - (cond [(not w) (lambda (in r _) (r in))] - [(procedure-arity-includes? w 3) w] - [else (lambda (in r _) (w in r))]))]) - (values - (lambda (in modpath line col pos) - (w2 in - (lambda (in) - (wrap-internal 'lib in rd w1 #f modpath #f - line col pos)) - #f)) - (lambda (src in modpath line col pos) - (w2 in - (lambda (in) - (wrap-internal 'lib in (lambda (in) (rds src in)) - w1 #t modpath src - line col pos)) - #t)))))))))])) + (let loop ([body (syntax->list #'(body ...))]) + (if (not (and (pair? body) + (pair? (cdr body)) + (not (keyword? (car body))))) + (datum->syntax stx body stx) + (let* ([k (car body)] [k* (syntax-e k)] [v (cadr body)]) + (cond + [(assq k* key-args) (err (format "got two ~s keywords" k*) k)] + [(not (memq k* '(#:read #:read-syntax #:wrapper1 #:wrapper2 + #:whole-body-readers?))) + (err "got an unknown keyword" (car body))] + [else (set! key-args (cons (cons k* v) key-args)) + (loop (cddr body))]))))) + (define (get kwd [dflt #f]) + (cond [(assq kwd key-args) => cdr] [else dflt])) + (unless (equal? (and (assq '#:read key-args) #t) + (and (assq '#:read-syntax key-args) #t)) + (err "must specify either both #:read and #:read-syntax, or none")) + (when (and (assq '#:whole-body-readers? key-args) + (not (assq '#:read key-args))) + (err "got a #:whole-body-readers? without #:read and #:read-syntax")) + (quasisyntax/loc stx + (#%module-begin + #,@-body + (#%provide (rename *read read) (rename *read-syntax read-syntax)) + (define-values (*read *read-syntax) + (let* ([rd #,(get '#:read #'read)] + [rds #,(get '#:read-syntax #'read-syntax)] + [w1 #,(get '#:wrapper1 #'#f)] + [w2 #,(get '#:wrapper2 #'#f)] + [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? #,(get '#:whole-body-readers? #'#f)]) + (values + (lambda (in modpath line col pos) + (w2 in + (lambda (in) + (wrap-internal base 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? + w1 #t modpath src line col pos)) + #t))))))))])) -(define (wrap-internal lib port read wrapper stx? modpath src line col pos) +(define-syntax-rule (wrap-internal lib port read whole? wrapper stx? + modpath src line col pos) (let* ([body (lambda () - (let loop ([a null]) - (let ([v (read port)]) - (if (eof-object? v) (reverse a) (loop (cons v a))))))] + (if whole? + (read port) + (let loop ([a null]) + (let ([v (read port)]) + (if (eof-object? v) (reverse a) (loop (cons v a)))))))] [body (cond [(not wrapper) (body)] [(procedure-arity-includes? wrapper 2) (wrapper body stx?)] [else (wrapper body)])] @@ -96,6 +92,6 @@ (if stx? (datum->syntax #f r) r))) (define (wrap lib port read modpath src line col pos) - (wrap-internal lib port read #f #f modpath src line col pos)) + (wrap-internal lib 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 a806669ec7..4bad28f8ae 100644 --- a/collects/syntax/scribblings/module-reader.scrbl +++ b/collects/syntax/scribblings/module-reader.scrbl @@ -1,7 +1,8 @@ #lang scribble/doc @(require "common.ss") -@(require (for-label syntax/module-reader)) +@(require (for-label syntax/module-reader + (only-in scribble/reader read-syntax-inside read-inside))) @title[#:tag "module-reader"]{Module Reader} @@ -19,7 +20,8 @@ customized in a number of ways. ([reader-option (code:line #:read read-expr) (code:line #:read-syntax read-syntax-expr) (code:line #:wrapper1 wrapper1-expr) - (code:line #:wrapper2 wrapper2-expr)])]{ + (code:line #:wrapper2 wrapper2-expr) + (code:line #:whole-body-readers? whole?-expr)])]{ Causes a module written in the @schememodname[syntax/module-reader] language to define and provide @schemeidfont{read} and @@ -119,6 +121,12 @@ using this option: (r in)))) ] +In some cases, the reader functions read the whole file, so there is +no need to iterate them (e.g., @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: