From e06d072534735a43f903f12dd3a3334fedb03cc3 Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Wed, 30 Apr 2008 19:18:52 +0000
Subject: [PATCH] moved all of the framework's function documentation into the
scribble/srcdoc world
svn: r9545
original commit: 3eb20f5a11269e7f1948c67c655efedab0766dd7
---
collects/scribble/extract.ss | 16 +++++++++++++---
collects/scribble/srcdoc.ss | 20 ++++++++++++--------
2 files changed, 25 insertions(+), 11 deletions(-)
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))])))