From aee87f3568df9713782673741244692554c65e3a Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 3 Jan 2008 19:07:02 +0000 Subject: [PATCH] 3.99.0.9: binding links in docs use nominal import sources svn: r8196 original commit: 7fc41024c0f09d03bed22c9e68bc2548f9222b77 --- collects/scribble/base-render.ss | 48 +- collects/scribble/basic.ss | 8 +- collects/scribble/decode.ss | 3 +- collects/scribble/html-render.ss | 7 +- collects/scribble/manual.ss | 510 +++++++++++------- collects/scribble/scheme.ss | 77 +-- collects/scribble/search.ss | 126 +++++ collects/scribble/struct.ss | 66 ++- collects/scribble/xref.ss | 81 +-- collects/scribblings/scribble/bnf.scrbl | 2 +- collects/scribblings/scribble/decode.scrbl | 2 +- collects/scribblings/scribble/doclang.scrbl | 4 +- collects/scribblings/scribble/docreader.scrbl | 2 +- collects/scribblings/scribble/how-to.scrbl | 30 +- collects/scribblings/scribble/manual.scrbl | 47 +- collects/scribblings/scribble/reader.scrbl | 2 +- collects/scribblings/scribble/struct.scrbl | 2 +- collects/scribblings/scribble/xref.scrbl | 68 ++- 18 files changed, 717 insertions(+), 368 deletions(-) create mode 100644 collects/scribble/search.ss diff --git a/collects/scribble/base-render.ss b/collects/scribble/base-render.ss index 86951b12..c7b44680 100644 --- a/collects/scribble/base-render.ss +++ b/collects/scribble/base-render.ss @@ -4,7 +4,8 @@ mzlib/class mzlib/serialize scheme/file - scheme/path) + scheme/path + setup/main-collects) (provide render%) @@ -74,7 +75,9 @@ (make-hash-table 'equal) (make-hash-table) (make-hash-table) - "")]) + "" + (make-hash-table) + null)]) (start-collect ds fns ci) ci)) @@ -92,7 +95,9 @@ (string-append (collect-info-gen-prefix ci) (part-tag-prefix d) ":") - (collect-info-gen-prefix ci)))]) + (collect-info-gen-prefix ci)) + (collect-info-relatives ci) + (cons d (collect-info-parents ci)))]) (when (part-title-content d) (collect-content (part-title-content d) p-ci)) (collect-part-tags d p-ci number) @@ -184,16 +189,28 @@ (blockquote-paragraphs i))) (define/public (collect-element i ci) - (when (target-element? i) - (collect-target-element i ci)) - (when (index-element? i) - (collect-index-element i ci)) - (when (collect-element? i) - ((collect-element-collect i) ci)) - (when (element? i) - (for-each (lambda (e) - (collect-element e ci)) - (element-content i)))) + (if (part-relative-element? i) + (let ([content + (or (hash-table-get (collect-info-relatives ci) + i + #f) + (let ([v ((part-relative-element-collect i) ci)]) + (hash-table-put! (collect-info-relatives ci) + i + v) + v))]) + (collect-content content ci)) + (begin + (when (target-element? i) + (collect-target-element i ci)) + (when (index-element? i) + (collect-index-element i ci)) + (when (collect-element? i) + ((collect-element-collect i) ci)) + (when (element? i) + (for-each (lambda (e) + (collect-element e ci)) + (element-content i)))))) (define/public (collect-target-element i ci) (collect-put! ci @@ -213,6 +230,7 @@ (define/public (resolve ds fns ci) (let ([ri (make-resolve-info ci (make-hash-table) + (make-hash-table 'equal) (make-hash-table 'equal))]) (start-resolve ds fns ri) ri)) @@ -269,6 +287,8 @@ (define/public (resolve-element i d ri) (cond + [(part-relative-element? i) + (resolve-content (part-relative-element-content i ri) d ri)] [(delayed-element? i) (resolve-content (or (hash-table-get (resolve-info-delays ri) i @@ -372,6 +392,8 @@ (render-content (element-content i) part ri)] [(delayed-element? i) (render-content (delayed-element-content i ri) part ri)] + [(part-relative-element? i) + (render-content (part-relative-element-content i ri) part ri)] [else (render-other i part ri)])) diff --git a/collects/scribble/basic.ss b/collects/scribble/basic.ss index 82faf9ba..ef6fcbbb 100644 --- a/collects/scribble/basic.ss +++ b/collects/scribble/basic.ss @@ -47,20 +47,20 @@ style content))) - (define (subsection #:tag [tag #f] #:tag-prefix [prefix #f] . str) + (define (subsection #:tag [tag #f] #:tag-prefix [prefix #f] #:style [style #f] . str) (let ([content (decode-content str)]) (make-part-start 1 (prefix->string prefix) (convert-tag tag content) - #f + style content))) - (define (subsubsection #:tag [tag #f] #:tag-prefix [prefix #f] . str) + (define (subsubsection #:tag [tag #f] #:tag-prefix [prefix #f] #:style [style #f] . str) (let ([content (decode-content str)]) (make-part-start 2 (prefix->string prefix) (convert-tag tag content) - #f + style content))) (define (subsubsub*section #:tag [tag #f] . str) diff --git a/collects/scribble/decode.ss b/collects/scribble/decode.ss index d62a12ac..53989fb1 100644 --- a/collects/scribble/decode.ss +++ b/collects/scribble/decode.ss @@ -27,7 +27,8 @@ [splice ([run list?])] [part-index-decl ([plain-seq (listof string?)] [entry-seq list?])] - [part-collect-decl ([element element?])] + [part-collect-decl ([element (or/c element? + part-relative-element?)])] [part-tag-decl ([tag tag?])]) (define (decode-string s) diff --git a/collects/scribble/html-render.ss b/collects/scribble/html-render.ss index 1e4c82d3..d5596700 100644 --- a/collects/scribble/html-render.ss +++ b/collects/scribble/html-render.ss @@ -251,8 +251,11 @@ (append (loop (element-content a)) (loop (cdr c)))] [(delayed-element? a) - (loop (cons (delayed-element-content a ri) - (cdr c)))] + (loop (append (delayed-element-content a ri) + (cdr c)))] + [(part-relative-element? a) + (loop (append (part-relative-element-content a ri) + (cdr c)))] [else (loop (cdr c))]))])))] [table-targets diff --git a/collects/scribble/manual.ss b/collects/scribble/manual.ss index a014bc09..94efd8ba 100644 --- a/collects/scribble/manual.ss +++ b/collects/scribble/manual.ss @@ -3,6 +3,7 @@ (require "decode.ss" "struct.ss" "scheme.ss" + "search.ss" "config.ss" "basic.ss" "manual-struct.ss" @@ -10,6 +11,7 @@ scheme/class scheme/stxparam mzlib/serialize + setup/main-collects (for-syntax scheme/base) (for-label scheme/base scheme/class)) @@ -309,34 +311,74 @@ ;; ---------------------------------------- - (define-struct sig (tagstr)) + (define (gen-absolute-tag) + `(abs ,(make-generated-tag))) + + (define-struct sig (id)) (define (definition-site name stx-id form?) (let ([sig (current-signature)]) (if sig - (make-link-element (if form? - "schemesyntaxlink" - "schemevaluelink") - (list (schemefont (symbol->string name))) - `(,(if form? 'sig-form 'sig-val) - ,(format "~a::~a" (sig-tagstr sig) name))) + (*sig-elem (sig-id sig) name) (annote-exporting-library (to-element (make-just-context name stx-id)))))) - (define (id-to-tag id) - (add-signature-tag id #f)) + (define (libs->str libs) + (and (pair? libs) + (format "~a" + (let ([p (resolved-module-path-name + (module-path-index-resolve + (module-path-index-join (car libs) #f)))]) + (if (path? p) + (path->main-collects-relative p) + p))))) - (define (id-to-form-tag id) - (add-signature-tag id #t)) + (define (id-to-target-maker id dep?) + (*id-to-target-maker 'def id dep?)) - (define (add-signature-tag id form?) + (define (id-to-form-target-maker id dep?) + (*id-to-target-maker 'form id dep?)) + + (define (*id-to-target-maker sym id dep?) (let ([sig (current-signature)]) - (if sig - `(,(if form? 'sig-form 'sig-val) - ,(format "~a::~a" (sig-tagstr sig) (syntax-e id))) - (if form? - (register-scheme-form-definition id) - (register-scheme-definition id #t))))) + (lambda (content mk) + (make-part-relative-element + (lambda (ci) + (let ([e (ormap (lambda (p) + (ormap (lambda (e) + (and (exporting-libraries? e) e)) + (part-to-collect p))) + (collect-info-parents ci))]) + (unless e + ;; Call raise-syntax-error to capture error message: + (with-handlers ([exn:fail:syntax? (lambda (exn) + (fprintf (current-error-port) + "~a\n" + (exn-message exn)))]) + (raise-syntax-error 'WARNING + "no declared exporting libraries for definition" + id))) + (if e + (let* ([lib-str (libs->str (exporting-libraries-libs e))] + [tag (list (if sig + (case sym + [(def) 'sig-val] + [(form) 'sig-def]) + sym) + (format "~a::~a~a~a" + lib-str + (if sig (syntax-e (sig-id sig)) "") + (if sig "::" "") + (syntax-e id)))]) + (if (or sig (not dep?)) + (list (mk tag)) + (list (make-target-element + #f + (list (mk tag)) + `(dep ,(format "~a::~a" lib-str (syntax-e id))))))) + content))) + (lambda () (car content)) + (lambda () (car content)))))) (define current-signature (make-parameter #f)) @@ -344,21 +386,25 @@ (*sig-elem (quote-syntax sig) 'elem)) (define (*sig-elem sig elem) - (let ([s (to-element elem)] - [tag (format "~a::~a" - (register-scheme-form-definition sig #t) - elem)]) + (let ([s (to-element/no-color elem)]) (make-delayed-element (lambda (renderer sec ri) - (let* ([vtag `(sig-val ,tag)] - [stag `(sig-form ,tag)] - [sd (resolve-get/tentative sec ri stag)]) + (let* ([tag (find-scheme-tag sec ri sig 'for-label)] + [str (and tag (format "~a::~a" (cadr tag) elem))] + [vtag (and tag `(sig-val ,str))] + [stag (and tag `(sig-form ,str))] + [sd (and stag (resolve-get/tentative sec ri stag))]) (list - (cond - [sd - (make-link-element "schemesyntaxlink" (list s) stag)] - [else - (make-link-element "schemevaluelink" (list s) vtag)])))) + (make-element + "schemesymbol" + (list + (cond + [sd + (make-link-element "schemesyntaxlink" (list s) stag)] + [vtag + (make-link-element "schemevaluelink" (list s) vtag)] + [else + s])))))) (lambda () s) (lambda () s)))) @@ -379,15 +425,29 @@ (elem (method a b) " in " (scheme a))])) (define (*method sym id) - (**method sym (id-to-tag id))) + (**method sym id)) - (define (**method sym tag) - (make-element - "schemesymbol" - (list (make-link-element - "schemevaluelink" - (list (symbol->string sym)) - (method-tag tag sym))))) + (define (**method sym id/tag) + (let ([content (list (symbol->string sym))]) + ((if (identifier? id/tag) + (lambda (c mk) + (make-delayed-element + (lambda (ren p ri) + (let ([tag (find-scheme-tag p ri id/tag 'for-label)]) + (if tag + (list (mk tag)) + content))) + (lambda () (car content)) + (lambda () (car content)))) + (lambda (c mk) (mk id/tag))) + content + (lambda (tag) + (make-element + "schemesymbol" + (list (make-link-element + "schemevaluelink" + content + (method-tag tag sym)))))))) (define (method-tag vtag sym) (list 'meth @@ -458,12 +518,18 @@ (syntax-rules () [(_ lib ...) (*declare-exporting '(lib ...))])) + (define-struct (exporting-libraries element) (libs)) + (define (*declare-exporting libs) - (make-part-collect-decl - (make-collect-element #f - null - (lambda (ri) - (collect-put! ri '(exporting-libraries #f)libs))))) + (make-splice + (list + (make-part-collect-decl + (make-collect-element #f + null + (lambda (ri) + (collect-put! ri '(exporting-libraries #f) libs)))) + (make-part-collect-decl + (make-exporting-libraries #f null libs))))) (define-syntax (quote-syntax/loc stx) (syntax-case stx () @@ -1016,45 +1082,51 @@ (hspace 1) (if first? (let* ([mname (extract-id prototype)] - [ctag (id-to-tag within-id)] - [tag (method-tag ctag mname)] + [target-maker (id-to-target-maker within-id #f)] [content (list (*method mname within-id))]) - (if tag - (make-toc-target-element - #f - (list (make-index-element #f - content - tag - (list (symbol->string mname)) - content - (with-exporting-libraries - (lambda (libs) - (make-method-index-desc - (syntax-e within-id) - libs - mname - ctag))))) - tag) + (if target-maker + (target-maker + content + (lambda (ctag) + (let ([tag (method-tag ctag mname)]) + (make-toc-target-element + #f + (list (make-index-element #f + content + tag + (list (symbol->string mname)) + content + (with-exporting-libraries + (lambda (libs) + (make-method-index-desc + (syntax-e within-id) + libs + mname + ctag))))) + tag)))) (car content))) (*method (extract-id prototype) within-id))))] [else (if first? - (let ([tag (id-to-tag stx-id)] + (let ([target-maker (id-to-target-maker stx-id #t)] [content (list (definition-site (extract-id prototype) stx-id #f))]) - (if tag - (make-toc-target-element - #f - (list (make-index-element #f - content - tag - (list (symbol->string (extract-id prototype))) - content - (with-exporting-libraries - (lambda (libs) - (make-procedure-index-desc - (extract-id prototype) - libs))))) - tag) + (if target-maker + (target-maker + content + (lambda (tag) + (make-toc-target-element + #f + (list (make-index-element #f + content + tag + (list (symbol->string (extract-id prototype))) + content + (with-exporting-libraries + (lambda (libs) + (make-procedure-index-desc + (extract-id prototype) + libs))))) + tag))) (car content))) (annote-exporting-library (to-element (make-just-context (extract-id prototype) @@ -1241,27 +1313,31 @@ (let* ([name (apply string-append (map symbol->string (cdar wrappers)))] - [tag - (id-to-tag + [target-maker + (id-to-target-maker (datum->syntax stx-id (string->symbol - name)))]) - (if tag - (inner-make-target-element - #f - (list - (make-index-element #f - (list content) - tag - (list name) - (list (schemeidfont (make-element "schemevaluelink" (list name)))) - (with-exporting-libraries - (lambda (libs) - (let ([name (string->symbol name)]) - (if (eq? 'info (caar wrappers)) - (make-struct-index-desc name libs) - (make-procedure-index-desc name libs))))))) - tag) + name)) + #t)]) + (if target-maker + (target-maker + (list content) + (lambda (tag) + (inner-make-target-element + #f + (list + (make-index-element #f + (list content) + tag + (list name) + (list (schemeidfont (make-element "schemevaluelink" (list name)))) + (with-exporting-libraries + (lambda (libs) + (let ([name (string->symbol name)]) + (if (eq? 'info (caar wrappers)) + (make-struct-index-desc name libs) + (make-procedure-index-desc name libs))))))) + tag))) content)) (cdr wrappers)))) @@ -1454,20 +1530,24 @@ (list (make-flow (list (make-paragraph - (list (let ([tag ((if form? id-to-form-tag id-to-tag) stx-id)] + (list (let ([target-maker ((if form? id-to-form-target-maker id-to-target-maker) stx-id #t)] [content (list (definition-site name stx-id form?))]) - (if tag - (make-toc-target-element - #f - (list (make-index-element #f - content - tag - (list (symbol->string name)) - content - (with-exporting-libraries - (lambda (libs) - (make-thing-index-desc name libs))))) - tag) + (if target-maker + (target-maker + content + (lambda (tag) + (make-toc-target-element + #f + (list + (make-index-element #f + content + tag + (list (symbol->string name)) + content + (with-exporting-libraries + (lambda (libs) + (make-thing-index-desc name libs))))) + tag))) (car content))) spacer ":" spacer)))) (make-flow @@ -1520,31 +1600,29 @@ `(,x . ,(cdr form))))))) (and kw-id (eq? form (car forms)) - (let ([tag (id-to-tag kw-id)] - [stag (id-to-form-tag kw-id)] + (let ([target-maker (id-to-form-target-maker kw-id #t)] [content (list (definition-site (if (pair? form) (car form) form) kw-id #t))]) - (if tag - (make-target-element - #f - (list - (make-toc-target-element - #f - (if kw-id - (list (make-index-element #f - content - tag - (list (symbol->string (syntax-e kw-id))) - content - (with-exporting-libraries - (lambda (libs) - (make-form-index-desc (syntax-e kw-id) libs))))) - content) - stag)) - tag) + (if target-maker + (target-maker + content + (lambda (tag) + (make-toc-target-element + #f + (if kw-id + (list (make-index-element #f + content + tag + (list (symbol->string (syntax-e kw-id))) + content + (with-exporting-libraries + (lambda (libs) + (make-form-index-desc (syntax-e kw-id) libs))))) + content) + tag))) (car content))))))))) forms form-procs) (if (null? sub-procs) @@ -1680,9 +1758,19 @@ (make-link-element (if u? #f "plainlink") null `(part ,(doc-prefix doc s)))) (define (seclink tag #:underline? [u? #t] #:doc [doc #f] . s) (make-link-element (if u? #f "plainlink") (decode-content s) `(part ,(doc-prefix doc tag)))) + (define (*schemelink stx-id id . s) - (make-link-element #f (decode-content s) (or (register-scheme-definition stx-id) - (format "--UNDEFINED:~a--" (syntax-e stx-id))))) + (let ([content (decode-content s)]) + (make-delayed-element + (lambda (r p ri) + (list + (make-link-element #f + content + (or (find-scheme-tag p ri stx-id 'for-label) + (format "--UNDEFINED:~a--" (syntax-e stx-id)))))) + (lambda () content) + (lambda () content)))) + (define-syntax schemelink (syntax-rules () [(_ id . content) (*schemelink (quote-syntax id) 'id . content)])) @@ -1841,28 +1929,45 @@ (define-struct spec (def)) (define-struct impl (def)) + (define (id-info id) + (let ([b (identifier-label-binding id)]) + (list (let ([p (resolved-module-path-name (module-path-index-resolve (caddr b)))]) + (if (path? p) + (path->main-collects-relative p) + p)) + (cadddr b) + (list-ref b 5)))) + (define-serializable-struct cls/intf (name-element super intfs methods)) (define (make-inherited-table r d ri decl) - (let* ([start (let ([key (register-scheme-definition (decl-name decl))]) - (list (cons key (lookup-cls/intf d ri key))))] - [supers (cdr - (let loop ([supers start][accum null]) - (cond - [(null? supers) (reverse accum)] - [(memq (car supers) accum) - (loop (cdr supers) accum)] - [else - (let ([super (car supers)]) - (loop (append (map (lambda (i) - (cons i (lookup-cls/intf d ri i))) - (reverse (cls/intf-intfs (cdr super)))) - (let ([s (cls/intf-super (cdr super))]) - (if s - (list (cons s (lookup-cls/intf d ri s))) - null)) - (cdr supers)) - (cons super accum)))])))] + (let* ([start (let ([key (find-scheme-tag d ri (decl-name decl) 'for-label)]) + (if key + (list (cons key (lookup-cls/intf d ri key))) + null))] + [supers (if (null? start) + null + (cdr + (let loop ([supers start][accum null]) + (cond + [(null? supers) (reverse accum)] + [(memq (car supers) accum) + (loop (cdr supers) accum)] + [else + (let ([super (car supers)]) + (loop (append (filter values + (map (lambda (i) + (let ([key (find-scheme-tag d ri i 'for-label)]) + (and key + (cons key (lookup-cls/intf d ri key))))) + (reverse (cls/intf-intfs (cdr super))))) + (let ([s (and (cls/intf-super (cdr super)) + (find-scheme-tag d ri (cls/intf-super (cdr super)) 'for-label))]) + (if s + (list (cons s (lookup-cls/intf d ri s))) + null)) + (cdr supers)) + (cons super accum)))]))))] [ht (let ([ht (make-hash-table)]) (for-each (lambda (i) (when (meth? i) @@ -1902,27 +2007,29 @@ (define (make-decl-collect decl) (make-part-collect-decl - (make-collect-element - #f null - (lambda (ci) - (let ([tag (register-scheme-definition (decl-name decl))]) - (collect-put! ci - `(cls/intf ,tag) - (make-cls/intf - (make-element - "schemesymbol" - (list (make-link-element - "schemevaluelink" - (list (symbol->string (syntax-e (decl-name decl)))) - tag))) - (and (decl-super decl) - (not (free-label-identifier=? (quote-syntax object%) - (decl-super decl))) - (register-scheme-definition (decl-super decl))) - (map register-scheme-definition (decl-intfs decl)) - (map (lambda (m) - (meth-name m)) - (filter meth? (decl-body decl)))))))))) + ((id-to-target-maker (decl-name decl) #f) + (list "ignored") + (lambda (tag) + (make-collect-element + #f null + (lambda (ci) + (collect-put! ci + `(cls/intf ,(cadr tag)) + (make-cls/intf + (make-element + "schemesymbol" + (list (make-link-element + "schemevaluelink" + (list (symbol->string (syntax-e (decl-name decl)))) + tag))) + (and (decl-super decl) + (not (free-label-identifier=? (quote-syntax object%) + (decl-super decl))) + (id-info (decl-super decl))) + (map id-info (decl-intfs decl)) + (map (lambda (m) + (meth-name m)) + (filter meth? (decl-body decl))))))))))) (define (build-body decl body) (append @@ -1969,22 +2076,26 @@ (list (make-flow (list (make-paragraph - (list (let ([tag (id-to-tag stx-id)] + (list (let ([target-maker (id-to-target-maker stx-id #t)] [content (list (annote-exporting-library (to-element stx-id)))]) - (if tag - ((if whole-page? - make-page-target-element - make-toc-target-element) - #f - (list (make-index-element #f - content - tag - (list (symbol->string (syntax-e stx-id))) - content - (with-exporting-libraries - (lambda (libs) - (make-index-desc (syntax-e stx-id) libs))))) - tag) + (if target-maker + (target-maker + content + (lambda (tag) + ((if whole-page? + make-page-target-element + make-toc-target-element) + #f + (list + (make-index-element #f + content + tag + (list (symbol->string (syntax-e stx-id))) + content + (with-exporting-libraries + (lambda (libs) + (make-index-desc (syntax-e stx-id) libs))))) + tag))) (car content))) spacer ":" spacer (case kind @@ -2222,36 +2333,38 @@ (define (*xmethod/super cname name) (let ([get (lambda (d ri key) - (let ([v (lookup-cls/intf d ri key)]) - (if v - (cons (cls/intf-super v) - (cls/intf-intfs v)) - null)))] - [ctag (id-to-tag cname)]) + (if key + (let ([v (lookup-cls/intf d ri key)]) + (if v + (cons (cls/intf-super v) + (cls/intf-intfs v)) + null)) + null))]) (make-delayed-element (lambda (r d ri) - (let loop ([search (get d ri ctag)]) + (let loop ([search (get d ri (find-scheme-tag d ri cname 'for-label))]) (cond [(null? search) (list (make-element #f '("")))] [(not (car search)) (loop (cdr search))] [else - (let ([v (lookup-cls/intf d ri (car search))]) + (let* ([a-key (find-scheme-tag d ri (car search) 'for-label)] + [v (and a-key (lookup-cls/intf d ri a-key))]) (if v (if (member name (cls/intf-methods v)) (list (make-element #f - (list (**method name (car search)) + (list (**method name a-key) " in " (cls/intf-name-element v)))) - (loop (append (cdr search) (get d ri (car search))))) + (loop (append (cdr search) (get d ri (find-scheme-tag d ri (car search) 'for-label))))) (loop (cdr search))))]))) (lambda () (format "~a in ~a" (syntax-e cname) name)) (lambda () (format "~a in ~a" (syntax-e cname) name))))) - (define (lookup-cls/intf d ri name) - (let ([v (resolve-get d ri `(cls/intf ,name))]) + (define (lookup-cls/intf d ri tag) + (let ([v (resolve-get d ri `(cls/intf ,(cadr tag)))]) (or v (make-cls/intf "unknown" #f @@ -2294,8 +2407,7 @@ #t (list (make-element #f '("signature"))) (lambda () - (let ([in (parameterize ([current-signature (make-sig - (id-to-form-tag stx-id))]) + (let ([in (parameterize ([current-signature (make-sig stx-id)]) (body-thunk))]) (if indent? (let-values ([(pre-body post-body) diff --git a/collects/scribble/scheme.ss b/collects/scribble/scheme.ss index e73736a3..44a76ea3 100644 --- a/collects/scribble/scheme.ss +++ b/collects/scribble/scheme.ss @@ -1,10 +1,12 @@ (module scheme scheme/base (require "struct.ss" "basic.ss" + "search.ss" mzlib/class mzlib/for setup/main-collects syntax/modresolve + syntax/modcode (for-syntax scheme/base)) (provide define-code @@ -12,8 +14,6 @@ to-element/no-color to-paragraph to-paragraph/prefix - register-scheme-definition - register-scheme-form-definition syntax-ize syntax-ize-hook current-keyword-list @@ -73,28 +73,30 @@ (values (substring s 1) #t #f) (values s #f #f))))]) (if (or (element? (syntax-e c)) - (delayed-element? (syntax-e c))) + (delayed-element? (syntax-e c)) + (part-relative-element? (syntax-e c))) (out (syntax-e c) #f) (out (if (and (identifier? c) color? (quote-depth . <= . 0) (not (or it? is-var?))) - (let ([tag (register-scheme c)]) - (if tag - (make-delayed-element - (lambda (renderer sec ri) - (let* ([vtag `(def ,tag)] - [stag `(form ,tag)] - [sd (resolve-get/tentative sec ri stag)]) - (list - (cond - [sd - (make-link-element "schemesyntaxlink" (list s) stag)] - [else - (make-link-element "schemevaluelink" (list s) vtag)])))) - (lambda () s) - (lambda () s)) - s)) + (if (pair? (identifier-label-binding c)) + (make-delayed-element + (lambda (renderer sec ri) + (let* ([tag (find-scheme-tag sec ri c 'for-label)]) + (if tag + (list + (case (car tag) + [(form) + (make-link-element "schemesyntaxlink" (list s) tag)] + [else + (make-link-element "schemevaluelink" (list s) tag)])) + (list + (make-element "badlink" + (list (make-element "schemevaluelink" (list s)))))))) + (lambda () s) + (lambda () s)) + s) (literalize-spaces s)) (cond [(positive? quote-depth) value-color] @@ -155,6 +157,8 @@ (element-width v)] [(delayed-element? v) (element-width v)] + [(part-relative-element? v) + (element-width v)] [(spaces? v) (+ (sz-loop (car (element-content v))) (spaces-cnt v) @@ -538,41 +542,6 @@ [(_ code typeset-code) #'(define-code code typeset-code unsyntax)])) - (define (register-scheme stx [warn-if-no-label? #f]) - (unless (identifier? stx) - (error 'register-scheme-definition "not an identifier: ~e" (syntax->datum stx))) - (let ([b (identifier-label-binding stx)]) - (if (or (not b) - (eq? b 'lexical)) - (if warn-if-no-label? - (begin - (fprintf (current-error-port) - "~a\n" - ;; Call raise-syntax-error to capture error message: - (with-handlers ([exn:fail:syntax? (lambda (exn) - (exn-message exn))]) - (raise-syntax-error 'WARNING - "no for-label binding of identifier" - stx))) - (format ":NOLABEL:~a" (syntax-e stx))) - #f) - (format ":~a:~a" - (let ([p (resolve-module-path-index (car b) #f)]) - (if (path? p) - (path->main-collects-relative p) - p)) - (cadr b))))) - - (define (register-scheme/invent stx warn-if-no-label?) - (or (register-scheme stx warn-if-no-label?) - (format ":UNKNOWN:~a" (syntax-e stx)))) - - (define (register-scheme-definition stx [warn-if-no-label? #f]) - `(def ,(register-scheme/invent stx warn-if-no-label?))) - - (define (register-scheme-form-definition stx [warn-if-no-label? #f]) - `(form ,(register-scheme/invent stx warn-if-no-label?))) - (define syntax-ize-hook (make-parameter (lambda (v col) #f))) (define (vector->short-list v extract) diff --git a/collects/scribble/search.ss b/collects/scribble/search.ss new file mode 100644 index 00000000..bc2e5cfa --- /dev/null +++ b/collects/scribble/search.ss @@ -0,0 +1,126 @@ +(module search scheme/base + (require "struct.ss" + "basic.ss" + setup/main-collects + syntax/modcode) + + (provide find-scheme-tag) + + (define module-info-cache (make-hash-table)) + + (define (module-path-index-rejoin mpi rel-to) + (let-values ([(name base) (module-path-index-split mpi)]) + (cond + [(not name) rel-to] + [(not base) mpi] + [else + (module-path-index-join name + (module-path-index-rejoin base rel-to))]))) + + ;; mode is #f, 'for-label, or 'for-run + (define (find-scheme-tag part ri stx/binding mode) + (let ([b (cond + [(identifier? stx/binding) + ((case mode + [(for-label) identifier-label-binding] + [(for-syntax) identifier-transformer-binding] + [else identifier-binding]) + stx/binding)] + [(and (list? stx/binding) + (= 6 (length stx/binding))) + stx/binding] + [else + (and (not (symbol? (car stx/binding))) + (let ([p (module-path-index-join + (main-collects-relative->path (car stx/binding)) + #f)]) + (list #f + (cadr stx/binding) + p + (cadr stx/binding) + #f + (if (= 2 (length stx/binding)) + mode + (caddr stx/binding)))))])]) + (and + (pair? b) + (let ([seen (make-hash-table)] + [search-key #f]) + (let loop ([queue (list (list (caddr b) (cadddr b) (eq? mode (list-ref b 5))))] + [rqueue null]) + (cond + [(null? queue) + (if (null? rqueue) + ;; Not documented + #f + (loop (reverse rqueue) null))] + [else + (let ([mod (caar queue)] + [id (cadar queue)] + [here? (caddar queue)] + [queue (cdr queue)]) + (let* ([rmp (module-path-index-resolve mod)] + [eb (and here? + (format "~a::~a" + (let ([p (resolved-module-path-name rmp)]) + (if (path? p) + (path->main-collects-relative p) + p)) + id))]) + (when (and eb + (not search-key)) + (set! search-key eb)) + (let ([v (and eb (resolve-search search-key part ri `(dep ,eb)))]) + (or (and v + (let ([v (resolve-get/tentative part ri `(form ,eb))]) + (or (and v `(form ,eb)) + `(def ,eb)))) + ;; Maybe it's re-exported from this module... + ;; Try a shortcut: + (if (eq? rmp (and (car b) (module-path-index-resolve (car b)))) + ;; Not defined through this path, so keep looking + (loop queue rqueue) + ;; Check parents, if we can get the source: + (if (and (path? (resolved-module-path-name rmp)) + (not (hash-table-get seen rmp #f))) + (let ([exports + (hash-table-get + module-info-cache + rmp + (lambda () + (let-values ([(run-vals run-stxes + syntax-vals syntax-stxes + label-vals label-stxes) + (module-compiled-exports + (get-module-code (resolved-module-path-name rmp)))]) + (let ([t (list (append run-vals run-stxes) + (append syntax-vals syntax-stxes) + (append label-vals label-stxes))]) + (hash-table-put! module-info-cache rmp t) + t))))]) + (hash-table-put! seen rmp #t) + (let ([a (assq id (list-ref exports + (if here? + 0 + (case mode + [(for-syntax) 1] + [(for-label) 2] + [else 0]))))]) + (if a + (loop queue + (append (map (lambda (m) + (if (pair? m) + (list (module-path-index-rejoin (car m) mod) + (caddr m) + (or here? + (eq? mode (cadr m)))) + (list (module-path-index-rejoin m mod) + id + here?))) + (cadr a)) + rqueue)) + (error 'find-scheme-tag + "dead end when looking for binding source: ~e" + id)))) + ;; Can't get the module source, so continue with queue: + (loop queue rqueue)))))))]))))))) \ No newline at end of file diff --git a/collects/scribble/struct.ss b/collects/scribble/struct.ss index 98f45a40..f4be3e84 100644 --- a/collects/scribble/struct.ss +++ b/collects/scribble/struct.ss @@ -6,8 +6,8 @@ ;; ---------------------------------------- - (define-struct collect-info (ht ext-ht parts tags gen-prefix)) - (define-struct resolve-info (ci delays undef)) + (define-struct collect-info (ht ext-ht parts tags gen-prefix relatives parents)) + (define-struct resolve-info (ci delays undef searches)) (define (part-collected-info part ri) (hash-table-get (collect-info-parts (resolve-info-ci ri)) @@ -49,6 +49,18 @@ #t)) v)) + (define (resolve-search search-key part ri key) + (let ([s-ht (hash-table-get (resolve-info-searches ri) + search-key + (lambda () + (let ([s-ht (make-hash-table 'equal)]) + (hash-table-put! (resolve-info-searches ri) + search-key + s-ht) + s-ht)))]) + (hash-table-put! s-ht key #t)) + (resolve-get part ri key)) + (define (resolve-get/tentative part ri key) (let-values ([(v ext?) (resolve-get/where part ri key)]) v)) @@ -69,6 +81,7 @@ part-collected-info collect-put! resolve-get + resolve-search resolve-get/tentative resolve-get-keys) @@ -163,12 +176,11 @@ [target-url ([addr string?])] [image-file ([path path-string?])]) - + ;; ---------------------------------------- ;; Delayed element has special serialization support: (define-struct delayed-element (resolve sizer plain) - #:mutable #:property prop:serializable (make-serialize-info @@ -210,6 +222,47 @@ ;; ---------------------------------------- + ;; part-relative element has special serialization support: + (define-struct part-relative-element (collect sizer plain) + #:property + prop:serializable + (make-serialize-info + (lambda (d) + (let ([ri (current-serialize-resolve-info)]) + (unless ri + (error 'serialize-part-relative-element + "current-serialize-resolve-info not set")) + (with-handlers ([exn:fail:contract? + (lambda (exn) + (error 'serialize-part-relative-element + "serialization failed (wrong resolve info?); ~a" + (exn-message exn)))]) + (vector + (make-element #f (part-relative-element-content d ri)))))) + #'deserialize-part-relative-element + #f + (or (current-load-relative-directory) (current-directory)))) + + (provide/contract + (struct part-relative-element ([collect (collect-info? . -> . list?)] + [sizer (-> any)] + [plain (-> any)]))) + + (provide deserialize-part-relative-element) + (define deserialize-part-relative-element + (make-deserialize-info values values)) + + (provide part-relative-element-content) + (define (part-relative-element-content e ci/ri) + (hash-table-get (collect-info-relatives (if (resolve-info? ci/ri) + (resolve-info-ci ci/ri) + ci/ri)) + e)) + + (provide collect-info-parents) + + ;; ---------------------------------------- + ;; Delayed index entry also has special serialization support. ;; It uses the same delay -> value table as delayed-element (define-struct delayed-index-desc (resolve) @@ -336,6 +389,7 @@ [(c) (cond [(element? c) (content->string (element-content c))] + [(part-relative-element? c) (element->string ((part-relative-element-plain c)))] [(delayed-element? c) (element->string ((delayed-element-plain c)))] [(string? c) c] [else (case c @@ -356,6 +410,9 @@ [(delayed-element? c) (content->string (delayed-element-content c ri) renderer sec ri)] + [(part-relative-element? c) + (content->string (part-relative-element-content c ri) + renderer sec ri)] [else (element->string c)])])) (define (strip-aux content) @@ -376,6 +433,7 @@ [(string? s) (string-length s)] [(element? s) (apply + (map element-width (element-content s)))] [(delayed-element? s) (element-width ((delayed-element-sizer s)))] + [(part-relative-element? s) (element-width ((part-relative-element-sizer s)))] [else 1])) (define (paragraph-width s) diff --git a/collects/scribble/xref.ss b/collects/scribble/xref.ss index 4440ca82..85ff2ede 100644 --- a/collects/scribble/xref.ss +++ b/collects/scribble/xref.ss @@ -4,6 +4,7 @@ scribble/manual-struct scribble/decode-struct scribble/base-render + scribble/search (prefix-in html: scribble/html-render) scheme/class mzlib/serialize @@ -74,46 +75,50 @@ (void)))) ;; Returns (values ) -(define (xref-binding-tag xrefs src id) - (let ([search - (lambda (src) - (let ([base (format ":~a:~a" - (if (path? src) - (path->main-collects-relative src) - src) - id)] - [ht (collect-info-ext-ht (resolve-info-ci (xrefs-ri xrefs)))]) - (let ([form-tag `(form ,base)] - [val-tag `(def ,base)]) - (if (hash-table-get ht form-tag #f) - (values form-tag #t) - (if (hash-table-get ht val-tag #f) - (values val-tag #f) - (values #f #f))))))]) - (let loop ([src src]) +(define xref-binding-tag + (case-lambda + [(xrefs id/binding mode) + (let ([search + (lambda (id/binding) + (let ([tag (find-scheme-tag #f (xrefs-ri xrefs) id/binding mode)]) + (if tag + (values tag (eq? (car tag) 'form)) + (values #f #f))))]) (cond - [(path? src) - (if (complete-path? src) - (search src) - (loop (path->complete-path src)))] - [(path-string? src) - (loop (path->complete-path src))] - [(resolved-module-path? src) - (let ([n (resolved-module-path-name src)]) - (if (pair? n) - (loop n) - (search n)))] - [(module-path-index? src) - (loop (module-path-index-resolve src))] - [(module-path? src) - (loop (module-path-index-join src #f))] - [else - (raise-type-error 'xref-binding-definition->tag - "module path, resolved module path, module path index, path, or string" - src)])))) + [(identifier? id/binding) + (search id/binding)] + [(and (list? id/binding) + (= 6 (length id/binding))) + (search id/binding)] + [(and (list? id/binding) + (= 2 (length id/binding))) + (let loop ([src (car id/binding)]) + (cond + [(path? src) + (if (complete-path? src) + (search (list src (cadr id/binding))) + (loop (path->complete-path src)))] + [(path-string? src) + (loop (path->complete-path src))] + [(resolved-module-path? src) + (let ([n (resolved-module-path-name src)]) + (if (pair? n) + (loop n) + (search n)))] + [(module-path-index? src) + (loop (module-path-index-resolve src))] + [(module-path? src) + (loop (module-path-index-join src #f))] + [else + (raise-type-error 'xref-binding-definition->tag + "list starting with module path, resolved module path, module path index, path, or string" + src)]))] + [else (raise-type-error 'xref-binding-definition->tag + "identifier, 2-element list, or 6-element list" + id/binding)]))])) -(define (xref-binding->definition-tag xrefs src id) - (let-values ([(tag form?) (xref-binding-tag xrefs src id)]) +(define (xref-binding->definition-tag xrefs id/binding mode) + (let-values ([(tag form?) (xref-binding-tag xrefs id/binding mode)]) tag)) (define (xref-tag->path+anchor xrefs tag #:render% [render% (html:render-mixin render%)]) diff --git a/collects/scribblings/scribble/bnf.scrbl b/collects/scribblings/scribble/bnf.scrbl index 72cd5a80..a8dc78af 100644 --- a/collects/scribblings/scribble/bnf.scrbl +++ b/collects/scribblings/scribble/bnf.scrbl @@ -3,7 +3,7 @@ "utils.ss" (for-label scribble/bnf)) -@title[#:tag "bnf"]{Typesetting Grammars} +@title[#:tag "bnf"]{BNF Grammars} @defmodule[scribble/bnf]{The @scheme[scribble/bnf] library provides utilities for typesetting grammars.} diff --git a/collects/scribblings/scribble/decode.scrbl b/collects/scribblings/scribble/decode.scrbl index f94a7459..95ba732c 100644 --- a/collects/scribblings/scribble/decode.scrbl +++ b/collects/scribblings/scribble/decode.scrbl @@ -2,7 +2,7 @@ @require[scribble/manual] @require["utils.ss"] -@title[#:tag "decode"]{Text Decoder} +@title[#:tag "decode"]{Decoding Text} @defmodule[scribble/decode]{The @schememodname[scribble/decode] library helps you write document content in a natural way---more like diff --git a/collects/scribblings/scribble/doclang.scrbl b/collects/scribblings/scribble/doclang.scrbl index f2ebb8fe..68055313 100644 --- a/collects/scribblings/scribble/doclang.scrbl +++ b/collects/scribblings/scribble/doclang.scrbl @@ -2,9 +2,9 @@ @require[scribble/manual] @require["utils.ss"] -@title[#:tag "doclang"]{Document Module Language} +@title[#:tag "doclang"]{Document Language} -@defmodule[scribble/doclang]{The @schememodname[scribble/doclang] +@defmodulelang[scribble/doclang]{The @schememodname[scribble/doclang] language provides everything from @scheme[scheme/base], except that it replaces the @scheme[#%module-begin] form.} diff --git a/collects/scribblings/scribble/docreader.scrbl b/collects/scribblings/scribble/docreader.scrbl index ebfc4899..5e484d88 100644 --- a/collects/scribblings/scribble/docreader.scrbl +++ b/collects/scribblings/scribble/docreader.scrbl @@ -5,7 +5,7 @@ @title[#:tag "docreader"]{Document Reader} -@defmodule[scribble/doc]{The @schememodname[scribble/doc] language is +@defmodulelang[scribble/doc]{The @schememodname[scribble/doc] language is the same as @schememodname[scribble/doclang], except that @scheme[read-inside-syntax] is used to read the body of the module. In other words, the module body starts in Scribble ``text'' mode instead diff --git a/collects/scribblings/scribble/how-to.scrbl b/collects/scribblings/scribble/how-to.scrbl index 09e785f0..3e8122d9 100644 --- a/collects/scribblings/scribble/how-to.scrbl +++ b/collects/scribblings/scribble/how-to.scrbl @@ -292,7 +292,9 @@ hyperlinks. To document a @scheme[my-helper] procedure that is exported by @filepath{helper.ss} in the collection that contains @filepath{manual.scrbl}, first use @scheme[(require (for-label ....))] -to import the binding information of @filepath{helper.ss}. Then use +to import the binding information of @filepath{helper.ss}. Then add a +@scheme[defmodule] declaration, which connects the @scheme[for-label] +binding with the module path as seen by a reader. Finally, use @scheme[defproc] to document the procedure: @verbatim[#<definition-tag [xref xref?] - [mod (or/c module-path? - module-path-index? - path? - resolved-module-path?)] - [sym symbol?]) + [binding (or/c identifier? + (list/c (or/c module-path? + module-path-index? + path? + resolved-module-path?) + symbol?) + (listof module-path-index? + symbol? + module-path-index? + symbol? + boolean? + (one-of/c #f 'for-syntax 'for-label)) + (list/c (or/c module-path? + module-path-index? + path? + resolved-module-path?) + symbol? + (one-of/c #f 'for-syntax 'for-label)))] + [mode (one-of/c #f 'for-syntax 'for-label)]) (or/c tag? false/c)]{ -Locates a tag in @scheme[xref] that documents @scheme[sym] as defined -by @scheme[mod]. The @scheme[sym] and @scheme[mod] combination -correspond to the first two elements of a @scheme[identifier-binding] -list result. +Locates a tag in @scheme[xref] that documents a module export. The +binding is specified in one of several ways, as described below; all +possibilities encode an exporting module and a symbolic name. The name +must be exported from the specified module. Documentation is found +either for the specified module or, if the exported name is +re-exported from other other module, for the other module +(transitively). + +The @scheme[mode] argument specifies more information about the +binding: whether it refers to a normal binding, a @scheme[for-syntax] +binding, or a @scheme[for-label] binding. + +The @scheme[binding] is specified in one of four ways: + +@itemize{ + + @item{If @scheme[binding] is an identifier, then + @scheme[identifier-binding], + @scheme[identifier-transformer-binding], or + @scheme[identifier-label-binding] is used to determine the + binding, depending on the value of @scheme[mode].} + + @item{If @scheme[binding] is a two-element list, then the first + element provides the exporting module and the second the + exported name. The @scheme[mode] argument is effectively + ignored.} + + @item{If @scheme[binding] is a six-element list, then it corresponds + to a result from @scheme[identifier-binding], + @scheme[identifier-transformer-binding], or + @scheme[identifier-label-binding], depending on the value of + @scheme[mode].} + + @item{If @scheme[binding] is a three-element list, then the first + element is as for the 2-element-list case, the second element + is like the fourth element of the six-element case, and the + third element is like the sixth element of the six-element + case.} + +} If a documentation point exists in @scheme[xref], a tag is returned, which might be used with @scheme[xref-tag->path+anchor] or embedded in