extend syntax/module-reader to avoid ugly hack in scribble/doc/reader
svn: r11517
This commit is contained in:
Eli Barzilay
parent
8ed6a0c00f
commit
eaa5a69fa5
|
|
@ -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"))
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
||||
)
|
||||
|
|
|
|||
|
|
@ -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:
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user