diff --git a/collects/scribble/extract.ss b/collects/scribble/extract.ss index 4fddc25a..fa141146 100644 --- a/collects/scribble/extract.ss +++ b/collects/scribble/extract.ss @@ -20,8 +20,12 @@ (define-syntax (include-extracted stx) (syntax-case stx () - [(_ orig-path) - (let ([path (resolve-path-spec #'orig-path #'orig-path stx)]) + [(_ orig-path) #'(include-extracted orig-path #rx"")] ;; this regexp matches everything + [(_ orig-path regexp-s) + (let ([path (resolve-path-spec #'orig-path #'orig-path stx)] + [reg (syntax-e #'regexp-s)]) + (unless (regexp? reg) + (raise-syntax-error #f "expected a literal regular expression as the second argument" stx #'regexp-s)) (let ([s-exp (parameterize ([current-namespace (make-base-namespace)] [read-accept-reader #t]) @@ -40,7 +44,13 @@ (map (lambda (c) (syntax-case c (#%plain-app void quote-syntax provide/doc) [(#%plain-app void (quote-syntax (provide/doc spec ...))) - (syntax->list #'(spec ...))] + (map + (λ (x) (syntax-case x () [(docs id) #'docs])) + (filter (λ (x) + (syntax-case x () + [(stuff id) + (regexp-match reg (symbol->string (syntax-e #'id)))])) + (syntax->list #'(spec ...))))] [_ null])) (syntax->list #'(content ...))))] [(req ...) diff --git a/collects/scribble/srcdoc.ss b/collects/scribble/srcdoc.ss index c6b8203d..391d8f68 100644 --- a/collects/scribble/srcdoc.ss +++ b/collects/scribble/srcdoc.ss @@ -17,7 +17,7 @@ (syntax-case stx () [(_ form ...) (let ([forms (syntax->list #'(form ...))]) - (with-syntax ([((for-provide/contract for-docs) ...) + (with-syntax ([((for-provide/contract for-docs id) ...) (map (lambda (form) (syntax-case form () [(id . _) @@ -31,9 +31,10 @@ #'id)) (let* ([i (make-syntax-introducer)] [i2 (lambda (x) (syntax-local-introduce (i x)))]) - (let-values ([(p/c d req/d) ((provide/doc-transformer-proc t) - (i (syntax-local-introduce form)))]) - (list (i2 p/c) (list (i2 req/d) (i2 d) (i2 (quote-syntax tag)))))))] + (let-values ([(p/c d req/d id) + ((provide/doc-transformer-proc t) + (i (syntax-local-introduce form)))]) + (list (i2 p/c) (list (i2 req/d) (i2 d) (i2 (quote-syntax tag))) (i2 id)))))] [_ (raise-syntax-error #f @@ -49,7 +50,7 @@ (syntax->list #'(for-provide/contract ...)))]) #'(begin p/c ... - (void (quote-syntax (provide/doc for-docs ...)))))))])) + (void (quote-syntax (provide/doc (for-docs id) ...)))))))])) (define-provide/doc-transformer proc-doc (lambda (stx) @@ -94,7 +95,8 @@ (values #'[id contract] #'(defproc header result . desc) - #'(scribble/manual)))]))) + #'(scribble/manual) + #'id))]))) (define-provide/doc-transformer proc-doc/names (lambda (stx) @@ -146,7 +148,8 @@ (values #'[id contract] #'(defproc* header . desc) - #'(scribble/manual)))]))) + #'(scribble/manual) + #'id))]))) (define-provide/doc-transformer parameter-doc (lambda (stx) @@ -166,4 +169,5 @@ (values #'[id (parameter/c contract)] #'(defparam id arg-id contract . desc) - #'(scribble/manual)))]))) + #'(scribble/manual) + #'id))])))