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

extend syntax/module-reader to avoid ugly hack in scribble/doc/reader

Browse Source 
svn: r11517
This commit is contained in:
Eli Barzilay 2008-09-02 04:06:08 +00:00
parent 8ed6a0c00f
commit eaa5a69fa5
3 changed files with 74 additions and 83 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

21
collects/scribble/doc/reader.ss
View File

@ -2,22 +2,9 @@
scribble/doclang scribble/doclang
;; `read-inside' reads the whole body, so make wrapper1 return null so #:read scribble:read-inside
;; we get the right syntax, and then make wrapper2 do the actual #:read-syntax scribble:read-syntax-inside
;; reading. This might seem extreme, but I think that it's still #:whole-body-readers? #t
;; better to use module-reader for the subtleties it deals with. #:wrapper1 (lambda (t) (list* 'doc '() (t)))
#: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)))
(require (prefix-in scribble: "../reader.ss")) (require (prefix-in scribble: "../reader.ss"))

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

@ -9,72 +9,68 @@
(define-syntax (provide-module-reader stx) (define-syntax (provide-module-reader stx)
(syntax-case stx () (syntax-case stx ()
[(_ lib body ...) [(_ lib body ...)
(let ([-read #f] (let ([key-args '()])
[-read-syntax #f] (define (err str [sub #f])
[-wrapper1 #f] (raise-syntax-error 'syntax/module-reader str sub))
[-wrapper2 #f])
(define -body (define -body
(let loop ([body #'(body ...)]) (let loop ([body (syntax->list #'(body ...))])
(define (err str) (if (not (and (pair? body)
(raise-syntax-error 'syntax/module-reader str (pair? (cdr body))
(car (syntax->list body)))) (not (keyword? (car body)))))
(syntax-case body () (datum->syntax stx body stx)
[(#:read r body ...) (let* ([k (car body)] [k* (syntax-e k)] [v (cadr body)])
(if -read (cond
(err "got two #:read keywords") [(assq k* key-args) (err (format "got two ~s keywords" k*) k)]
(begin (set! -read #'r) (loop #'(body ...))))] [(not (memq k* '(#:read #:read-syntax #:wrapper1 #:wrapper2
[(#:read-syntax r body ...) #:whole-body-readers?)))
(if -read-syntax (err "got an unknown keyword" (car body))]
(err "got two #:read-syntax keywords") [else (set! key-args (cons (cons k* v) key-args))
(begin (set! -read-syntax #'r) (loop #'(body ...))))] (loop (cddr body))])))))
[(#:wrapper1 w body ...) (define (get kwd [dflt #f])
(if -wrapper1 (cond [(assq kwd key-args) => cdr] [else dflt]))
(err "got two #:wrapper1 keywords") (unless (equal? (and (assq '#:read key-args) #t)
(begin (set! -wrapper1 #'w) (loop #'(body ...))))] (and (assq '#:read-syntax key-args) #t))
[(#:wrapper2 w body ...) (err "must specify either both #:read and #:read-syntax, or none"))
(if -wrapper2 (when (and (assq '#:whole-body-readers? key-args)
(err "got two #:wrapper2 keywords") (not (assq '#:read key-args)))
(begin (set! -wrapper2 #'w) (loop #'(body ...))))] (err "got a #:whole-body-readers? without #:read and #:read-syntax"))
[(k . b) (keyword? (syntax-e #'k)) (quasisyntax/loc stx
(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 (#%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* ([rd #,(get '#:read #'read)]
[rds -read-syntax] [rds #,(get '#:read-syntax #'read-syntax)]
[w1 -wrapper1] [w1 #,(get '#:wrapper1 #'#f)]
[w2 (let ([w -wrapper2]) [w2 #,(get '#:wrapper2 #'#f)]
(cond [(not w) (lambda (in r _) (r in))] [w2 (cond [(not w2) (lambda (in r _) (r in))]
[(procedure-arity-includes? w 3) w] [(procedure-arity-includes? w2 3) w2]
[else (lambda (in r _) (w in r))]))]) [else (lambda (in r _) (w2 in r))])]
[base 'lib]
[whole? #,(get '#:whole-body-readers? #'#f)])
(values (values
(lambda (in modpath line col pos) (lambda (in modpath line col pos)
(w2 in (w2 in
(lambda (in) (lambda (in)
(wrap-internal 'lib in rd w1 #f modpath #f (wrap-internal base in rd whole?
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 'lib in (lambda (in) (rds src in)) (wrap-internal
w1 #t modpath src base in (lambda (in) (rds src in)) whole?
line col pos)) w1 #t modpath src line col pos))
#t)))))))))])) #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* ([body (lambda ()
(if whole?
(read port)
(let loop ([a null]) (let loop ([a null])
(let ([v (read port)]) (let ([v (read port)])
(if (eof-object? v) (reverse a) (loop (cons v a))))))] (if (eof-object? v) (reverse a) (loop (cons v a)))))))]
[body (cond [(not wrapper) (body)] [body (cond [(not wrapper) (body)]
[(procedure-arity-includes? wrapper 2) (wrapper body stx?)] [(procedure-arity-includes? wrapper 2) (wrapper body stx?)]
[else (wrapper body)])] [else (wrapper body)])]
@ -96,6 +92,6 @@
(if stx? (datum->syntax #f r) r))) (if stx? (datum->syntax #f r) r)))
(define (wrap lib port read modpath src line col pos) (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))
) )

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

@ -1,7 +1,8 @@
#lang scribble/doc #lang scribble/doc
@(require "common.ss") @(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} @title[#:tag "module-reader"]{Module Reader}
@ -19,7 +20,8 @@ customized in a number of ways.
([reader-option (code:line #:read read-expr) ([reader-option (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)
(code:line #:whole-body-readers? whole?-expr)])]{
Causes a module written in the @schememodname[syntax/module-reader] Causes a module written in the @schememodname[syntax/module-reader]
language to define and provide @schemeidfont{read} and language to define and provide @schemeidfont{read} and
@ -119,6 +121,12 @@ using this option:
(r in)))) (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 Finally, note that the two wrappers can return a different value than
the wrapped function. This introduces two more customization points the wrapped function. This introduces two more customization points
for the resulting readers: for the resulting readers: