From d1a3a0a6c21fcbfe993026933b1f580bbbc7c9c2 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 12 Jul 2008 15:37:31 +0000 Subject: [PATCH] adjust the way framework and tools docs extract documentation svn: r10727 original commit: 01691d9240c55dc3797c17ab6d609b4c16145982 --- collects/scribble/extract.ss | 188 +++++++++++++++++++++++------------ collects/scribble/srcdoc.ss | 6 +- 2 files changed, 126 insertions(+), 68 deletions(-) diff --git a/collects/scribble/extract.ss b/collects/scribble/extract.ss index 1d51a912..66380c78 100644 --- a/collects/scribble/extract.ss +++ b/collects/scribble/extract.ss @@ -5,9 +5,12 @@ scribble/srcdoc (for-syntax scheme/base scheme/path - syntax/path-spec)) + syntax/path-spec + (for-syntax scheme/base))) -(provide include-extracted) +(provide include-extracted + provide-extracted + include-previously-extracted) (define-for-syntax (strip-context c) (cond @@ -19,72 +22,124 @@ (strip-context (cdr c)))] [else c])) +(define-for-syntax (extract orig-path stx) + (let ([path (resolve-path-spec orig-path orig-path stx)]) + (let ([s-exp + (parameterize ([current-namespace (make-base-namespace)] + [read-accept-reader #t] + [current-load-relative-directory + (path-only path)]) + (expand + (with-input-from-file path + (lambda () + (port-count-lines! (current-input-port)) + (read-syntax path)))))]) + (syntax-case s-exp () + [(mod name lang + (mod-beg + content ...)) + (with-syntax ([((content id) ...) + (apply + append + (map (lambda (c) + (syntax-case c (#%plain-app void quote-syntax provide/doc) + [(#%plain-app void (quote-syntax (provide/doc spec ...))) + (syntax->list #'(spec ...))] + [_ null])) + (syntax->list #'(content ...))))] + [(req ...) + (map + strip-context + (apply + append + (map (lambda (c) + (syntax-case c (#%require #%plain-app void quote-syntax require/doc) + [(#%require spec ...) + (let loop ([specs (syntax->list #'(spec ...))]) + (cond + [(null? specs) '()] + [else (let ([spec (car specs)]) + (syntax-case spec (for-syntax for-meta) + [(for-syntax . spec) (loop (cdr specs))] + [(for-meta . spec) (loop (cdr specs))] + [(for-template . spec) (loop (cdr specs))] + [(for-label . spec) (loop (cdr specs))] + [(just-meta . spec) (loop (cdr specs))] + [_ (cons #`(for-label #,spec) (loop (cdr specs)))]))]))] + [(#%plain-app void (quote-syntax (require/doc spec ...))) + (syntax->list #'(spec ...))] + [_ null])) + (syntax->list #'(content ...)))))] + [orig-tag (datum->syntax #f 'orig)]) + ;; This template is matched in `filter-info', below + #`(begin + (#%require (for-label #,(strip-context #'lang)) + (for-label #,(strip-context orig-path)) + req ...) + (drop-first (quote-syntax id) (def-it orig-tag content)) ...))])))) + (define-syntax (include-extracted stx) (syntax-case stx () - [(_ orig-path) #'(include-extracted orig-path #rx"")] ;; this regexp matches everything + [(_ orig-path) + (extract #'orig-path stx)])) + +(define-syntax (provide-extracted stx) + (syntax-case stx () + [(_ orig-path) + (with-syntax ([(_begin reqs (_drop-first (_quote-syntax id) def) ...) + (extract #'orig-path stx)]) + #'(begin + (require (for-label (only-in orig-path))) ;; creates build dependency + (define-syntax (extracted stx) + (syntax-case stx () + [(_ rx) + (let-syntax ([quote-syntax/loc + (lambda (stx) + (syntax-case stx () + [(_ s) + (let loop ([stx #'s]) + (cond + [(syntax? stx) + (let ([ctx (datum->syntax stx 'ctx #f #f stx)]) + (let ([s + #`(datum->syntax (quote-syntax #,ctx) + #,(loop (syntax-e stx)) + #,(and (syntax-position stx) + (vector (let ([s (syntax-source stx)]) + (if (path-string? s) + s + (format "~s" s))) + (syntax-line stx) + (syntax-column stx) + (syntax-position stx) + (syntax-span stx))))]) + (let ([p (syntax-property stx 'paren-shape)]) + (if p + #`(syntax-property #,s 'paren-shape '#,p) + s))))] + [(pair? stx) #`(cons #,(loop (car stx)) #,(loop (cdr stx)))] + [(vector? stx) #`(vector #,@(map loop (vector->list stx)))] + [(box? stx) #`(box #,(loop (unbox stx)))] + [else #`(quote #,stx)]))]))]) + #`(begin #,(quote-syntax/loc reqs) + #,@(filter + values + (map (lambda (i d) + (if (regexp-match (syntax-e #'rx) (symbol->string i)) + (d) + #f)) + (list 'id ...) + (list (lambda () (quote-syntax/loc def)) ...)))))])) + (provide extracted)))])) + +(define-syntax (include-previously-extracted stx) + (syntax-case stx () [(_ 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] - [current-load-relative-directory - (path-only path)]) - (expand - (with-input-from-file path - (lambda () - (port-count-lines! (current-input-port)) - (read-syntax path)))))]) - (syntax-case s-exp () - [(mod name lang - (mod-beg - content ...)) - (with-syntax ([(content ...) - (apply - append - (map (lambda (c) - (syntax-case c (#%plain-app void quote-syntax provide/doc) - [(#%plain-app void (quote-syntax (provide/doc 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 ...) - (map - strip-context - (apply - append - (map (lambda (c) - (syntax-case c (#%require #%plain-app void quote-syntax require/doc) - [(#%require spec ...) - (let loop ([specs (syntax->list #'(spec ...))]) - (cond - [(null? specs) '()] - [else (let ([spec (car specs)]) - (syntax-case spec (for-syntax for-meta) - [(for-syntax . spec) (loop (cdr specs))] - [(for-meta . spec) (loop (cdr specs))] - [(for-template . spec) (loop (cdr specs))] - [(for-label . spec) (loop (cdr specs))] - [(just-meta . spec) (loop (cdr specs))] - [_ (cons #`(for-label #,spec) (loop (cdr specs)))]))]))] - [(#%plain-app void (quote-syntax (require/doc spec ...))) - (syntax->list #'(spec ...))] - [_ null])) - (syntax->list #'(content ...)))))] - [orig-tag (datum->syntax #f 'orig)]) - #`(begin - (#%require (for-label #,(strip-context #'lang)) - (for-label #,(strip-context #'orig-path)) - req ...) - (def-it orig-tag content) ...))])))])) + (unless (regexp? (syntax-e #'regexp-s)) + (raise-syntax-error #f "expected a literal regular expression as the second argument" stx #'regexp-s)) + #`(begin + (require (only-in orig-path [#,(datum->syntax #'orig-path 'extracted) extracted])) + (extracted regexp-s))])) (define-for-syntax (revise-context c orig-tag new-tag tag) (cond @@ -94,6 +149,7 @@ new-tag orig-tag) (revise-context (syntax-e c) orig-tag new-tag tag) + c c)] [(pair? c) (cons (revise-context (car c) orig-tag new-tag tag) (revise-context (cdr c) orig-tag new-tag tag))] @@ -109,3 +165,5 @@ #`(begin (require . #,(revise-context #'reqs orig-tag new-tag #'tag)) #,(revise-context #'doc orig-tag new-tag #'tag)))]))) + +(define-syntax-rule (drop-first a b) b) diff --git a/collects/scribble/srcdoc.ss b/collects/scribble/srcdoc.ss index 8e51d2be..9b322619 100644 --- a/collects/scribble/srcdoc.ss +++ b/collects/scribble/srcdoc.ss @@ -183,7 +183,7 @@ (values #'[id contract] #'(defproc* header . desc) - #'(scribble/manual) + #'((only-in scribble/manual defproc*)) #'id))]))) (define-provide/doc-transformer parameter-doc @@ -204,7 +204,7 @@ (values #'[id (parameter/c contract)] #'(defparam id arg-id contract . desc) - #'(scribble/manual) + #'((only-in scribble/manual defparam)) #'id))]))) (define-provide/doc-transformer thing-doc @@ -220,5 +220,5 @@ (values #'[id contract] #'(defthing id contract . desc) - #'(scribble/manual) + #'((only-in scribble/manual defthing)) #'id))])))