diff --git a/collects/scribble/extract.rkt b/collects/scribble/extract.rkt index 0f928571..0c165ee8 100644 --- a/collects/scribble/extract.rkt +++ b/collects/scribble/extract.rkt @@ -1,187 +1,47 @@ -#lang scheme/base - -(require scribble/manual - scribble/decode - scribble/srcdoc - (for-syntax scheme/base - scheme/path - scheme/list - syntax/path-spec - syntax/modread - (for-syntax scheme/base))) +#lang racket/base +(require (for-syntax racket/base)) (provide include-extracted provide-extracted include-previously-extracted) -(define-for-syntax (strip-context c) - (cond - [(syntax? c) (datum->syntax - #f - (strip-context (syntax-e c)) - c)] - [(pair? c) (cons (strip-context (car c)) - (strip-context (cdr c)))] - [else c])) - -(define-for-syntax (extract orig-path stx) - (let* ([n-path (resolve-path-spec orig-path orig-path stx)] - [path (if (regexp-match? #rx#"[.]rkt$" (path->bytes n-path)) - (if (file-exists? n-path) - n-path - (let ([ss (path-replace-suffix n-path #".ss")]) - (if (file-exists? ss) - ss - n-path))) - n-path)]) - (let ([s-exp - (parameterize ([current-namespace (make-base-namespace)] - [current-load-relative-directory - (path-only path)]) - (expand - (with-module-reading-parameterization - (lambda () - (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 ...))))] - [(doc-req ...) - (map - strip-context - (append-map (lambda (c) - (syntax-case c (#%plain-app void quote-syntax require/doc) - [(#%plain-app void (quote-syntax (require/doc spec ...))) - (syntax->list #'(spec ...))] - [_ null])) - (syntax->list #'(content ...))))] - [(req ...) - (map - strip-context - (append-map (lambda (c) - (syntax-case c (#%require) - [(#%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)))]))]))] - [_ 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 ...) - (require doc-req ...) - (drop-first (quote-syntax id) (def-it orig-tag content)) ...))])))) +(define-for-syntax (do-include-extracted stx wraps) + (syntax-case stx () + [(_ module-path) + (with-syntax ([get-docs (syntax-local-lift-require + #'(only (submod module-path srcdoc) get-docs) + (datum->syntax stx 'get-docs))] + [(wrap ...) wraps]) + #'(begin + (define-syntax (docs stx) + (define docs (get-docs)) + (if (identifier? docs) + ;; normal: + (with-syntax ([(_ xwrap (... ...)) stx] + [id docs]) + #'(xwrap (... ...) id)) + ;; delayed: + (with-syntax ([(_ xwrap (... ...)) stx] + [(reqs ((id d) (... ...))) (get-docs)]) + #`(begin + (require . reqs) + (xwrap (... ...) (list (cons 'id d) (... ...))))))) + (docs wrap ...)))])) (define-syntax (include-extracted stx) - (syntax-case stx () - [(_ orig-path) - (extract #'orig-path stx)])) - + (do-include-extracted stx #'(map cdr))) + (define-syntax (provide-extracted stx) (syntax-case stx () - [(_ orig-path) - (with-syntax ([(_begin reqs doc-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) - #,(quote-syntax/loc doc-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) - (unless (regexp? (syntax-e #'regexp-s)) - (raise-syntax-error #f "expected a literal regular expression as the second argument" stx #'regexp-s)) + [(_ module-path) #`(begin - (require (only-in orig-path [#,(datum->syntax #'orig-path 'extracted) extracted])) - (extracted regexp-s))])) + #,(do-include-extracted stx #'(define exported)) + (provide exported))])) + +(define-syntax-rule (include-previously-extracted module-path regexp) + (let () + (local-require (rename-in module-path [exported exported])) + (for/list ([p (in-list exported)] + #:when (regexp-match regexp (symbol->string (car p)))) + (cdr p)))) -(define-for-syntax (revise-context c orig-tag new-tag tag) - (cond - [(syntax? c) - (datum->syntax - (if (bound-identifier=? tag (datum->syntax c 'tag)) - 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))] - [else c])) - -(define-syntax (def-it stx) - (syntax-local-introduce - (syntax-case (syntax-local-introduce stx) () - [(_ orig-path (reqs doc tag)) - (let ([new-tag ((make-syntax-introducer) - (datum->syntax #'orig-path 'new-tag))] - [orig-tag #'orig-path]) - #`(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/provide-doc-transform.rkt b/collects/scribble/provide-doc-transform.rkt index 8c126c1d..81451633 100644 --- a/collects/scribble/provide-doc-transform.rkt +++ b/collects/scribble/provide-doc-transform.rkt @@ -1,15 +1,7 @@ -#lang scheme/base - -(require (for-syntax scheme/base)) +#lang racket/base +(require "srcdoc.rkt") (provide define-provide/doc-transformer (for-syntax provide/doc-transformer? provide/doc-transformer-proc)) - -(begin-for-syntax - (define-struct provide/doc-transformer (proc) #:omit-define-syntaxes)) - -(define-syntax-rule (define-provide/doc-transformer id rhs) - (define-syntax id - (make-provide/doc-transformer rhs))) diff --git a/collects/scribble/srcdoc.rkt b/collects/scribble/srcdoc.rkt index e1253e78..e65c90f9 100644 --- a/collects/scribble/srcdoc.rkt +++ b/collects/scribble/srcdoc.rkt @@ -1,56 +1,122 @@ -#lang scheme/base +#lang racket/base (require racket/contract/base - (for-syntax scheme/base) - "provide-doc-transform.rkt") + (for-syntax racket/base + racket/require-transform + racket/provide-transform)) -(provide require/doc - provide/doc +(provide for-doc require/doc + provide/doc ; not needed anymore thing-doc parameter-doc proc-doc - proc-doc/names) + proc-doc/names + generate-delayed-documents) -(define-syntax-rule (require/doc spec ...) - (void (quote-syntax (require/doc spec ...)))) +(begin-for-syntax + (define requires null) + (define doc-body null) + (define generated? #f) + (define delayed? #f) -(define-syntax (provide/doc stx) + (define (add-requires!/decl specs) + (unless delayed? + (syntax-local-lift-module-end-declaration + #`(begin-for-syntax (add-requires! (quote-syntax #,specs))))) + (add-requires! (syntax-local-introduce specs))) + + (define (add-requires! specs) + (set! requires (cons specs requires))) + + (define (generate-doc-submodule!) + (unless generated? + (set! generated? #t) + (syntax-local-lift-module-end-declaration #'(doc-submodule))))) + +(define-syntax for-doc + (make-require-transformer + (lambda (stx) + (syntax-case stx () + [(_ spec ...) + (add-requires!/decl #'(spec ...))]) + (values null null)))) + +(define-syntax (doc-submodule stx) + (with-syntax ([((req ...) ...) + (map syntax-local-introduce (reverse requires))] + [doc-body + (map (lambda (s) (syntax-local-introduce + (syntax-shift-phase-level s #f))) + (reverse doc-body))]) + ;; This module will be required `for-template': + (if delayed? + ;; delayed mode: return syntax objects to drop into context: + #'(begin-for-syntax + (module* srcdoc #f + (require (for-syntax racket/base syntax/quote)) + (begin-for-syntax + (provide get-docs) + (define (get-docs) + (list (quote-syntax (req ... ...)) + (quote-syntax/keep-srcloc doc-body)))))) + ;; normal mode: return an identifier that holds the document: + (with-syntax ([((id d) ...) #'doc-body]) + #'(begin-for-syntax + (module* srcdoc #f + (require req ... ...) + (define docs (list (cons 'id d) ...)) + (require (for-syntax racket/base)) + (begin-for-syntax + (provide get-docs) + (define (get-docs) + #'docs)))))))) + +(define-syntax (require/doc stx) (syntax-case stx () - [(_ form ...) - (let ([forms (syntax->list #'(form ...))]) - (with-syntax ([((for-provide/contract for-docs id) ...) - (map (lambda (form) - (syntax-case form () - [(id . _) - (identifier? #'id) - (let ([t (syntax-local-value #'id (lambda () #f))]) - (unless (provide/doc-transformer? t) - (raise-syntax-error - #f - "not bound as a provide/doc transformer" - stx - #'id)) - (let* ([i (make-syntax-introducer)] - [i2 (lambda (x) (syntax-local-introduce (i x)))]) - (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 - "not a provide/doc sub-form" - stx - form)])) - forms)]) - (with-syntax ([(p/c ...) - (map (lambda (form f) - (quasisyntax/loc form - (provide/contract #,f))) - forms - (syntax->list #'(for-provide/contract ...)))]) - #'(begin - p/c ... - (void (quote-syntax (provide/doc (for-docs id) ...)))))))])) + [(_ spec ...) + (add-requires!/decl #'(spec ...)) + #'(begin)])) + +(define-for-syntax (do-provide/doc stx modes) + (let ([forms (list stx)]) + (with-syntax ([((for-provide/contract (req ...) d id) ...) + (map (lambda (form) + (syntax-case form () + [(id . _) + (identifier? #'id) + (let ([t (syntax-local-value #'id (lambda () #f))]) + (unless (provide/doc-transformer? t) + (raise-syntax-error + #f + "not bound as a provide/doc transformer" + stx + #'id)) + (let* ([i (make-syntax-introducer)] + [i2 (lambda (x) (syntax-local-introduce (i x)))]) + (let-values ([(p/c d req/d id) + ((provide/doc-transformer-proc t) + (i (syntax-local-introduce form)))]) + (list (i2 p/c) (i req/d) (i d) (i id)))))] + [_ + (raise-syntax-error + #f + "not a provide/doc sub-form" + stx + form)])) + forms)]) + (with-syntax ([(p/c ...) + (map (lambda (form f) + (quasisyntax/loc form + (contract-out #,f))) + forms + (syntax->list #'(for-provide/contract ...)))]) + (generate-doc-submodule!) + (set! doc-body (append (reverse (syntax->list #'((id d) ...))) + doc-body)) + (set! requires (cons #'(req ... ...) requires)) + (pre-expand-export #'(combine-out p/c ...) modes))))) + +(define-syntax-rule (provide/doc form ...) + (provide form ...)) (define-for-syntax (remove->i-deps stx) (syntax-case stx () @@ -61,6 +127,24 @@ [else (error 'remove->i-deps "unknown thing ~s" stx)])) +(provide define-provide/doc-transformer + (for-syntax + provide/doc-transformer? + provide/doc-transformer-proc)) + +(begin-for-syntax + (define-struct provide/doc-transformer (proc) + #:property + prop:provide-pre-transformer + (lambda (self) + (lambda (stx mode) + (do-provide/doc stx mode))))) + +(define-syntax-rule (define-provide/doc-transformer id rhs) + (define-syntax id + (make-provide/doc-transformer rhs))) + + (define-provide/doc-transformer proc-doc (lambda (stx) (syntax-case stx () @@ -144,7 +228,8 @@ (values #'[id contract] #'(defproc header result body-stuff ... . desc) - #'(scribble/manual) + #'(scribble/manual + racket/base) ; for `...' #'id))]))) (define-provide/doc-transformer proc-doc/names @@ -310,3 +395,10 @@ #'(defthing id contract . desc) #'((only-in scribble/manual defthing)) #'id))]))) + +(define-syntax (generate-delayed-documents stx) + (syntax-case stx () + [(_) + (begin + (set! delayed? #t) + #'(begin))])) diff --git a/collects/scribblings/scribble/srcdoc.scrbl b/collects/scribblings/scribble/srcdoc.scrbl index 50541e49..960cc44d 100644 --- a/collects/scribblings/scribble/srcdoc.scrbl +++ b/collects/scribblings/scribble/srcdoc.scrbl @@ -23,16 +23,17 @@ run-time overhead for the library. Similarly, typesetting the documentation does not require running the library. The two phases (run time versus documentation time) are kept separate in much the same way that the module system keeps expansion-time code separate -from run-time code. +from run-time code, and documentation information is recorded in a +submodule to be separately loadable from the enclosing module. For an example use, see the @filepath{file} collection's @filepath{gif.rkt} source file and the corresponding extraction in @filepath{scribblings/gif.scrbl}. As that example illustrates, -prefixing the module declaration with +starting the module declaration with -@verbatim[#:indent 2]{ - #reader scribble/reader -} +@racketblock[ + @#,hash-lang[] @#,racketmodname[at-exp] +] enables the @"@"-reader, which is handy for writing documentation expressions. @@ -43,27 +44,21 @@ expressions. @defmodule[scribble/srcdoc] -@defform[(provide/doc spec ...)]{ +Documentation information generated by @racketmodname[scribble/srcdoc] +forms are accumulated into a @racketidfont{srcdoc} submodule. The +generated submodule is accessed by the bindings of +@racketmodname[scribble/extract]. -Like @racket[provide] or @racket[provide/contract], but each -@racket[spec] uses a @deftech{documentation transformer} to describe -the exported identifier and its contract. +@defform[(for-doc require-spec ...)]{ -The currently supported @tech{documentation transformers} are -@racket[proc-doc], @racket[proc-doc/names], @racket[parameter-doc], -and @racket[thing-doc].} - - -@defform[(require/doc require-spec ...)]{ - -Like @racket[require], but for bindings that are needed at +A @racket[require] sub-form for bindings that are needed at documentation time (and documentation-expansion time, etc.) instead of -run time (and expansion time, etc.). A @racket[require-doc] form has +run time (and expansion time, etc.). A @racket[for-doc] import has no effect on a normal use of the library; it affects only documentation extraction. Typically, a library that uses @racketmodname[scribble/srcdoc] -includes at least @racket[(require/doc scribble/base scribble/manual)] +includes at least @racket[(require (for-doc scribble/base scribble/manual))] to get core Racket forms and basic Scribble functions to use in documentation expressions.} @@ -79,9 +74,9 @@ documentation expressions.} [optional contract-expr (code:line keyword contract-expr)])]{ -When used in @racket[provide/doc], exports @racket[id] with the +A @racket[provide] sub-form that exports @racket[id] with the contract described by @racket[contract] -just like using @racket[provide/contract]. +just like using @racket[contract-out]. The @racket[arg-spec] specifies the names of arguments and the default values, which are not @@ -124,15 +119,43 @@ Like @racket[proc-doc], but supporting contract forms that embed argument names. Only a subset of @racket[->i] and @racket[->d] forms are currently supported.} + @defform[(thing-doc id contract-expr dec-expr)]{ Like @racket[proc-doc], but for an export of an arbitrary value.} + @defform[#:literals (parameter/c) (parameter-doc id (parameter/c contract-expr) arg-id desc-expr)]{ Like @racket[proc-doc], but for exporting a parameter.} + +@defform[(generate-delayed-documents)]{ + +Causes documentation information to be recorded as a macro that is +expanded (along with any @racket[for-doc] imports) in the +module that uses @racket[include-extracted] or @racket[provide-extracted], +instead of within (a submodule of) the module that declares the information. + +Delaying document generation in this way allows @racket[(for-doc +(for-label ....))] imports that would otherwise create cyclic module +dependencies. + +To avoid problems with accumulated @racket[for-doc] imports across +modules, @racket[generate-delayed-documents] declaration should appear +before any @racket[for-doc] import.} + + +@defform[(require/doc require-spec ...)]{ + +A legacy shorthand for @racket[(require (for-doc require-spec ...))].} + + +@defform[(provide/doc spec ...)]{ + +A legacy alternative to @racket[(provide spec ...)]} + @; ---------------------------------------- @section{Extracting Documentation from Source} @@ -143,7 +166,8 @@ Like @racket[proc-doc], but for exporting a parameter.} Expands to a sequence of documentation forms extracted from @racket[module-path], which is expected to be a module that uses -@racketmodname[scribble/srcdoc].} +@racketmodname[scribble/srcdoc] (so that the module has a +@racketidfont{srcdoc} submodule).} @defform[(provide-extracted module-path)]{