diff --git a/collects/scribble/base-render.ss b/collects/scribble/base-render.ss index 397c8549..e918f79d 100644 --- a/collects/scribble/base-render.ss +++ b/collects/scribble/base-render.ss @@ -11,7 +11,7 @@ (class object% (init-field dest-dir) - + (define/public (get-dest-directory) dest-dir) @@ -42,210 +42,334 @@ [else (cons (car content) (strip-aux (cdr content)))])) + ;; ---------------------------------------- + ;; marshal info + + (define/public (get-serialize-version) + 1) + + (define/public (serialize-info ri) + (parameterize ([current-serialize-resolve-info ri]) + (serialize (collect-info-ht (resolve-info-ci ri))))) + + (define/public (deserialize-info v ci) + (let ([ht (deserialize v)] + [in-ht (collect-info-ext-ht ci)]) + (hash-table-for-each ht (lambda (k v) + (hash-table-put! in-ht k v))))) + (define/public (get-defined ci) + (hash-table-map (collect-info-ht ci) (lambda (k v) k))) + + (define/public (get-undefined ri) + (hash-table-map (resolve-info-undef ri) (lambda (k v) k))) + ;; ---------------------------------------- ;; global-info collection - (define/public (save-info fn info) - (let ([s (serialize info)]) - (with-output-to-file fn - (lambda () - (write s)) - 'truncate/replace))) - - (define/public (load-info fn info) - (let ([ht (deserialize (with-input-from-file fn read))]) - (hash-table-for-each ht (lambda (k v) - (hash-table-put! info k v)))) - info) - (define/public (collect ds fns) - (let ([ht (make-hash-table 'equal)]) - (map (lambda (d) - (collect-part d #f ht null)) - ds) - ht)) + (let ([ci (make-collect-info (make-hash-table 'equal) + (make-hash-table 'equal) + (make-hash-table) + (make-hash-table) + "")]) + (start-collect ds fns ci) + ci)) - (define/public (collect-part d parent ht number) - (let ([p-ht (make-hash-table 'equal)]) + (define/public (start-collect ds fns ci) + (map (lambda (d) + (collect-part d #f ci null)) + ds)) + + (define/public (collect-part d parent ci number) + (let ([p-ci (make-collect-info (make-hash-table 'equal) + (collect-info-ext-ht ci) + (collect-info-parts ci) + (collect-info-tags ci) + (if (part-tag-prefix d) + (string-append (collect-info-gen-prefix ci) + (part-tag-prefix d) + ":") + (collect-info-gen-prefix ci)))]) (when (part-title-content d) - (collect-content (part-title-content d) p-ht)) - (collect-part-tags d p-ht number) - (collect-content (part-to-collect d) p-ht) - (collect-flow (part-flow d) p-ht) + (collect-content (part-title-content d) p-ci)) + (collect-part-tags d p-ci number) + (collect-content (part-to-collect d) p-ci) + (collect-flow (part-flow d) p-ci) (let loop ([parts (part-parts d)] [pos 1]) (unless (null? parts) (let ([s (car parts)]) - (collect-part s d p-ht + (collect-part s d p-ci (cons (if (unnumbered-part? s) #f pos) number)) (loop (cdr parts) (if (unnumbered-part? s) pos (add1 pos)))))) - (set-part-collected-info! d (make-collected-info - number - parent - p-ht)) - (hash-table-for-each p-ht - (lambda (k v) - (hash-table-put! ht k v))))) + (hash-table-put! (collect-info-parts ci) + d + (make-collected-info + number + parent + (collect-info-ht p-ci))) + (let ([prefix (part-tag-prefix d)]) + (hash-table-for-each (collect-info-ht p-ci) + (lambda (k v) + (when (cadr k) + (hash-table-put! (collect-info-ht ci) + (if prefix + (convert-key prefix k) + k) + v))))))) - (define/public (collect-part-tags d ht number) + (define/private (convert-key prefix k) + (case (car k) + [(part tech) + (if (string? (cadr k)) + (list (car k) + (string-append prefix + ":" + (cadr k))) + k)] + [(index-entry) + (let ([v (convert-key prefix (cadr k))]) + (if (eq? v (cadr k)) + k + (list 'index-entry v)))] + [else k])) + + (define/public (collect-part-tags d ci number) (for-each (lambda (t) - (hash-table-put! ht `(part ,t) (list (part-title-content d) number))) + (hash-table-put! (collect-info-ht ci) + (generate-tag t ci) + (list (or (part-title-content d) '("???")) + number))) (part-tags d))) - (define/public (collect-content c ht) + (define/public (collect-content c ci) (for-each (lambda (i) - (collect-element i ht)) + (collect-element i ci)) c)) - (define/public (collect-paragraph p ht) - (collect-content (paragraph-content p) ht)) + (define/public (collect-paragraph p ci) + (collect-content (paragraph-content p) ci)) - (define/public (collect-flow p ht) + (define/public (collect-flow p ci) (for-each (lambda (p) - (collect-flow-element p ht)) + (collect-flow-element p ci)) (flow-paragraphs p))) - (define/public (collect-flow-element p ht) + (define/public (collect-flow-element p ci) (cond - [(table? p) (collect-table p ht)] - [(itemization? p) (collect-itemization p ht)] - [(blockquote? p) (collect-blockquote p ht)] + [(table? p) (collect-table p ci)] + [(itemization? p) (collect-itemization p ci)] + [(blockquote? p) (collect-blockquote p ci)] [(delayed-flow-element? p) (void)] - [else (collect-paragraph p ht)])) + [else (collect-paragraph p ci)])) - (define/public (collect-table i ht) + (define/public (collect-table i ci) (for-each (lambda (d) (when (flow? d) - (collect-flow d ht))) + (collect-flow d ci))) (apply append (table-flowss i)))) - (define/public (collect-itemization i ht) - (for-each (lambda (d) (collect-flow d ht)) + (define/public (collect-itemization i ci) + (for-each (lambda (d) (collect-flow d ci)) (itemization-flows i))) - (define/public (collect-blockquote i ht) - (for-each (lambda (d) (collect-flow-element d ht)) + (define/public (collect-blockquote i ci) + (for-each (lambda (d) (collect-flow-element d ci)) (blockquote-paragraphs i))) - (define/public (collect-element i ht) + (define/public (collect-element i ci) (when (target-element? i) - (collect-target-element i ht)) + (collect-target-element i ci)) (when (index-element? i) - (collect-index-element i ht)) + (collect-index-element i ci)) + (when (collect-element? i) + ((collect-element-collect i) ci)) (when (element? i) (for-each (lambda (e) - (collect-element e ht)) + (collect-element e ci)) (element-content i)))) - (define/public (collect-target-element i ht) - (hash-table-put! ht (target-element-tag i) (list i))) + (define/public (collect-target-element i ci) + (collect-put! ci + (generate-tag (target-element-tag i) ci) + (list i))) - (define/public (collect-index-element i ht) - (hash-table-put! ht `(index-entry ,(index-element-tag i)) - (list (index-element-plain-seq i) - (index-element-entry-seq i)))) + (define/public (collect-index-element i ci) + (collect-put! ci + `(index-entry ,(generate-tag (index-element-tag i) ci)) + (list (index-element-plain-seq i) + (index-element-entry-seq i)))) - (define/public (lookup part ht key) - (let ([v (hash-table-get (if part - (collected-info-info (part-collected-info part)) - ht) - key - #f)]) - (or v - (and part - (lookup (collected-info-parent - (part-collected-info part)) - ht - key))))) + ;; ---------------------------------------- + ;; global-info resolution + + (define/public (resolve ds fns ci) + (let ([ri (make-resolve-info ci + (make-hash-table) + (make-hash-table 'equal))]) + (start-resolve ds fns ri) + ri)) + + (define/public (start-resolve ds fns ri) + (map (lambda (d) + (resolve-part d ri)) + ds)) + + (define/public (resolve-part d ri) + (when (part-title-content d) + (resolve-content (part-title-content d) d ri)) + (resolve-flow (part-flow d) d ri) + (for-each (lambda (p) + (resolve-part p ri)) + (part-parts d))) + + (define/public (resolve-content c d ri) + (for-each (lambda (i) + (resolve-element i d ri)) + c)) + + (define/public (resolve-paragraph p d ri) + (resolve-content (paragraph-content p) d ri)) + + (define/public (resolve-flow p d ri) + (for-each (lambda (p) + (resolve-flow-element p d ri)) + (flow-paragraphs p))) + + (define/public (resolve-flow-element p d ri) + (cond + [(table? p) (resolve-table p d ri)] + [(itemization? p) (resolve-itemization p d ri)] + [(blockquote? p) (resolve-blockquote p d ri)] + [(delayed-flow-element? p) + (let ([v ((delayed-flow-element-resolve p) this d ri)]) + (hash-table-put! (resolve-info-delays ri) p v) + (resolve-flow-element v d ri))] + [else (resolve-paragraph p d ri)])) + + (define/public (resolve-table i d ri) + (for-each (lambda (f) (when (flow? f) + (resolve-flow f d ri))) + (apply append (table-flowss i)))) + + (define/public (resolve-itemization i d ri) + (for-each (lambda (f) (resolve-flow f d ri)) + (itemization-flows i))) + + (define/public (resolve-blockquote i d ri) + (for-each (lambda (f) (resolve-flow-element f d ri)) + (blockquote-paragraphs i))) + + (define/public (resolve-element i d ri) + (cond + [(delayed-element? i) + (resolve-content (or (hash-table-get (resolve-info-delays ri) + i + #f) + (let ([v ((delayed-element-resolve i) this d ri)]) + (hash-table-put! (resolve-info-delays ri) + i + v) + v)) + d ri)] + [(element? i) + (cond + [(link-element? i) + (let-values ([(dest ext?) (resolve-get/where d ri (link-element-tag i))]) + (when ext? + (hash-table-put! (resolve-info-undef ri) + (tag-key (link-element-tag i) ri) + #t)))]) + (for-each (lambda (e) + (resolve-element e d ri)) + (element-content i))])) ;; ---------------------------------------- ;; render methods - (define/public (render ds fns ht) + (define/public (render ds fns ri) (map (lambda (d fn) (printf " [Output to ~a]\n" fn) (with-output-to-file fn (lambda () - (render-one d ht fn)) + (render-one d ri fn)) 'truncate/replace)) - ds fns)) - (define/public (render-one d ht fn) - (render-part d ht)) + (define/public (render-one d ri fn) + (render-part d ri)) - (define/public (render-part d ht) + (define/public (render-part d ri) (list (when (part-title-content d) - (render-content (part-title-content d) d ht)) - (render-flow (part-flow d) d ht) - (map (lambda (s) (render-part s ht)) + (render-content (part-title-content d) d ri)) + (render-flow (part-flow d) d ri) + (map (lambda (s) (render-part s ri)) (part-parts d)))) - (define/public (render-content c part ht) + (define/public (render-content c part ri) (apply append (map (lambda (i) - (render-element i part ht)) + (render-element i part ri)) c))) - (define/public (render-paragraph p part ht) - (render-content (paragraph-content p) part ht)) + (define/public (render-paragraph p part ri) + (render-content (paragraph-content p) part ri)) - (define/public (render-flow p part ht) + (define/public (render-flow p part ri) (apply append (map (lambda (p) - (render-flow-element p part ht)) + (render-flow-element p part ri)) (flow-paragraphs p)))) - (define/public (render-flow-element p part ht) + (define/public (render-flow-element p part ri) (cond [(table? p) (if (auxiliary-table? p) - (render-auxiliary-table p part ht) - (render-table p part ht))] - [(itemization? p) (render-itemization p part ht)] - [(blockquote? p) (render-blockquote p part ht)] - [(delayed-flow-element? p) (render-flow-element - ((delayed-flow-element-render p) this part ht) - part ht)] - [else (render-paragraph p part ht)])) + (render-auxiliary-table p part ri) + (render-table p part ri))] + [(itemization? p) (render-itemization p part ri)] + [(blockquote? p) (render-blockquote p part ri)] + [(delayed-flow-element? p) + (render-flow-element (delayed-flow-element-flow-elements p ri) part ri)] + [else (render-paragraph p part ri)])) - (define/public (render-auxiliary-table i part ht) + (define/public (render-auxiliary-table i part ri) null) - (define/public (render-table i part ht) + (define/public (render-table i part ri) (map (lambda (d) (if (flow? i) - (render-flow d part ht) + (render-flow d part ri) null)) (apply append (table-flowss i)))) - (define/public (render-itemization i part ht) - (map (lambda (d) (render-flow d part ht)) + (define/public (render-itemization i part ri) + (map (lambda (d) (render-flow d part ri)) (itemization-flows i))) - (define/public (render-blockquote i part ht) - (map (lambda (d) (render-flow-element d part ht)) + (define/public (render-blockquote i part ri) + (map (lambda (d) (render-flow-element d part ri)) (blockquote-paragraphs i))) - (define/public (render-element i part ht) + (define/public (render-element i part ri) (cond [(and (link-element? i) (null? (element-content i))) - (let ([v (lookup part ht (link-element-tag i))]) + (let ([v (resolve-get part ri (link-element-tag i))]) (if v - (render-content (strip-aux (car v)) part ht) - (render-content (list "[missing]") part ht)))] + (render-content (strip-aux (car v)) part ri) + (render-content (list "[missing]") part ri)))] [(element? i) - (render-content (element-content i) part ht)] + (render-content (element-content i) part ri)] [(delayed-element? i) - (render-content (force-delayed-element i this part ht) part ht)] + (render-content (delayed-element-content i ri) part ri)] [else - (render-other i part ht)])) + (render-other i part ri)])) - (define/public (render-other i part ht) + (define/public (render-other i part ri) (list i)) ;; ---------------------------------------- @@ -280,34 +404,32 @@ ;; ---------------------------------------- - (define/private (do-table-of-contents part ht delta quiet) - (make-table #f (render-toc part - (+ delta - (length (collected-info-number - (part-collected-info part)))) - #t - quiet))) + (define/private (do-table-of-contents part ri delta quiet) + (make-table #f (generate-toc part + ri + (+ delta + (length (collected-info-number + (part-collected-info part ri)))) + #t + quiet))) - (define/public (table-of-contents part ht) - (do-table-of-contents part ht -1 not)) + (define/public (table-of-contents part ri) + (do-table-of-contents part ri -1 not)) - (define/public (local-table-of-contents part ht) - (table-of-contents part ht)) + (define/public (local-table-of-contents part ri) + (table-of-contents part ri)) - (define/public (quiet-table-of-contents part ht) - (do-table-of-contents part ht 1 (lambda (x) #t))) + (define/public (quiet-table-of-contents part ri) + (do-table-of-contents part ri 1 (lambda (x) #t))) - (define/private (render-toc part base-len skip? quiet) - (let ([number (collected-info-number (part-collected-info part))]) + (define/private (generate-toc part ri base-len skip? quiet) + (let ([number (collected-info-number (part-collected-info part ri))]) (let ([subs - (if (quiet (and (styled-part? part) - (let ([st(styled-part-style part)]) - (or (eq? 'quiet st) - (and (list? st) (memq 'quiet st)))) + (if (quiet (and (part-style? part 'quiet) (not (= base-len (sub1 (length number)))))) (apply append - (map (lambda (p) (render-toc p base-len #f quiet)) (part-parts part))) + (map (lambda (p) (generate-toc p ri base-len #f quiet)) (part-parts part))) null)]) (if skip? subs @@ -324,8 +446,8 @@ (format-number number (list (make-element 'hspace '(" ")))) - (part-title-content part)) - `(part ,(car (part-tags part))))))))) + (or (part-title-content part) '("???"))) + (car (part-tags part)))))))) subs)]) (if (and (= 1 (length number)) (or (not (car number)) diff --git a/collects/scribble/basic.ss b/collects/scribble/basic.ss index 8a60e165..0ec3c1b9 100644 --- a/collects/scribble/basic.ss +++ b/collects/scribble/basic.ss @@ -4,7 +4,9 @@ "struct.ss" "config.ss" (lib "list.ss") - (lib "class.ss")) + (lib "class.ss") + (lib "main-collects.ss" "setup") + (lib "modresolve.ss" "syntax")) (provide title section @@ -18,21 +20,41 @@ (content->string content) "_")) - (define (title #:tag [tag #f] #:style [style #f] . str) + (define (prefix->string p) + (and p + (if (string? p) + p + (module-path-prefix->string p)))) + + (define (title #:tag [tag #f] #:tag-prefix [prefix #f] #:style [style #f] . str) (let ([content (decode-content str)]) - (make-title-decl (or tag (gen-tag content)) style content))) + (make-title-decl (prefix->string prefix) + `((part ,(or tag (gen-tag content)))) + style + content))) - (define (section #:tag [tag #f] #:style [style #f] . str) + (define (section #:tag [tag #f] #:tag-prefix [prefix #f] #:style [style #f] . str) (let ([content (decode-content str)]) - (make-part-start 0 (or tag (gen-tag content)) style content))) + (make-part-start 0 (prefix->string prefix) + `((part ,(or tag (gen-tag content)))) + style + content))) - (define (subsection #:tag [tag #f] . str) + (define (subsection #:tag [tag #f] #:tag-prefix [prefix #f] . str) (let ([content (decode-content str)]) - (make-part-start 1 (or tag (gen-tag content)) #f content))) + (make-part-start 1 + (prefix->string prefix) + `((part ,(or tag (gen-tag content)))) + #f + content))) - (define (subsubsection #:tag [tag #f] . str) + (define (subsubsection #:tag [tag #f] #:tag-prefix [prefix #f] . str) (let ([content (decode-content str)]) - (make-part-start 2 (or tag (gen-tag content)) #f content))) + (make-part-start 2 + (prefix->string prefix) + `((part ,(or tag (gen-tag content)))) + #f + content))) (define (subsubsub*section #:tag [tag #f] . str) (let ([content (decode-content str)]) @@ -47,6 +69,14 @@ ;; ---------------------------------------- + (provide module-path-prefix->string) + + (define (module-path-prefix->string p) + (format "~a" (path->main-collects-relative + (resolve-module-path p #f)))) + + ;; ---------------------------------------- + (provide itemize item item?) (define (itemize . items) @@ -124,19 +154,16 @@ (define (section-index . elems) (make-part-index-decl (map element->string elems) elems)) - (define (gen-target) - (format "index:~s:~s" (current-inexact-milliseconds) (gensym))) - (define (record-index word-seq element-seq tag content) (make-index-element #f - (list (make-target-element #f content tag)) - tag + (list (make-target-element #f content `(idx ,tag))) + `(idx ,tag) word-seq element-seq)) (define (index* word-seq content-seq . s) - (let ([key (gen-target)]) + (let ([key (make-generated-tag)]) (record-index word-seq content-seq key @@ -149,7 +176,7 @@ (apply index* word-seq word-seq s))) (define (as-index . s) - (let ([key (gen-target)] + (let ([key (make-generated-tag)] [content (decode-content s)]) (record-index (list (content->string content)) (list (make-element #f content)) @@ -158,18 +185,21 @@ (define (index-section tag) (make-unnumbered-part - (and tag (list tag)) - (list "Index") #f + `((part , (or tag + (make-generated-tag)))) + '("Index") + 'index null (make-flow (list (make-delayed-flow-element - (lambda (renderer sec ht) + (lambda (renderer sec ri) (let ([l null]) (hash-table-for-each (collected-info-info (part-collected-info (collected-info-parent - (part-collected-info sec)))) + (part-collected-info sec ri)) + ri)) (lambda (k v) (if (and (pair? k) (eq? 'index-entry (car k))) @@ -204,8 +234,7 @@ (commas (caddr i)) (car i)))))))) l)))))))) - null - 'index)) + null)) ;; ---------------------------------------- @@ -214,13 +243,13 @@ (define (table-of-contents) (make-delayed-flow-element - (lambda (renderer part ht) - (send renderer table-of-contents part ht)))) + (lambda (renderer part ri) + (send renderer table-of-contents part ri)))) (define (local-table-of-contents) (make-delayed-flow-element - (lambda (renderer part ht) - (send renderer local-table-of-contents part ht))))) + (lambda (renderer part ri) + (send renderer local-table-of-contents part ri))))) diff --git a/collects/scribble/decode.ss b/collects/scribble/decode.ss index a21c3ca4..e4a78e9d 100644 --- a/collects/scribble/decode.ss +++ b/collects/scribble/decode.ss @@ -13,16 +13,19 @@ whitespace?) (provide-structs - [title-decl ([tag any/c] + [title-decl ([tag-prefix (or/c false/c string?)] + [tags (listof tag?)] [style any/c] [content list?])] [part-start ([depth integer?] - [tag (or/c false/c string?)] + [tag-prefix (or/c false/c string?)] + [tags (listof tag?)] [style any/c] [title list?])] [splice ([run list?])] [part-index-decl ([plain-seq (listof string?)] - [entry-seq list?])]) + [entry-seq list?])] + [part-collect-decl ([element element?])]) (define (decode-string s) (let loop ([l '((#rx"---" mdash) @@ -52,39 +55,42 @@ null (list (decode-paragraph (reverse (skip-whitespace accum)))))) - (define (decode-flow* l keys tag style title part-depth) - (let loop ([l l][next? #f][keys keys][accum null][title title][tag tag][style style]) + (define (decode-flow* l keys colls tag-prefix tags style title part-depth) + (let loop ([l l][next? #f][keys keys][colls colls][accum null][title title][tag-prefix tag-prefix][tags tags][style style]) (cond [(null? l) - (let ([tags (map (lambda (k) - (format "secindex:~a:~a" (current-inexact-milliseconds) (gensym))) - keys)] - [tag (or tag (format "sec:~a:~a" (current-inexact-milliseconds) (gensym)))]) - (make-styled-part (cons tag - tags) - title - #f - (let ([l (map (lambda (k tag) - (make-index-element - #f - null - `(part ,tag) - (part-index-decl-plain-seq k) - (part-index-decl-entry-seq k))) - keys tags)]) - (if title - (cons (make-index-element - #f - null - `(part ,tag) - (list (regexp-replace #px"^(?:A|An|The)\\s" (content->string title) - "")) - (list (make-element #f title))) - l) - l)) - (make-flow (decode-accum-para accum)) - null - style))] + (let ([k-tags (map (lambda (k) + `(idx ,(make-generated-tag))) + keys)] + [tags (if (null? tags) + (list `(part ,(make-generated-tag))) + tags)]) + (make-part tag-prefix + (append tags k-tags) + title + style + (let ([l (map (lambda (k tag) + (make-index-element + #f + null + tag + (part-index-decl-plain-seq k) + (part-index-decl-entry-seq k))) + keys k-tags)]) + (append + (if title + (cons (make-index-element + #f + null + (car tags) + (list (regexp-replace #px"^(?:A|An|The)\\s" (content->string title) + "")) + (list (make-element #f title))) + l) + l) + colls)) + (make-flow (decode-accum-para accum)) + null))] [(title-decl? (car l)) (unless part-depth (error 'decode @@ -94,34 +100,35 @@ (error 'decode "found extra title: ~v" (car l))) - (loop (cdr l) next? keys accum + (loop (cdr l) next? keys colls accum (title-decl-content (car l)) - (title-decl-tag (car l)) + (title-decl-tag-prefix (car l)) + (title-decl-tags (car l)) (title-decl-style (car l)))] [(flow-element? (car l)) (let ([para (decode-accum-para accum)] - [part (decode-flow* (cdr l) keys tag style title part-depth)]) - (make-styled-part (part-tags part) - (part-title-content part) - (part-collected-info part) - (part-to-collect part) - (make-flow (append para - (list (car l)) - (flow-paragraphs (part-flow part)))) - (part-parts part) - (styled-part-style part)))] + [part (decode-flow* (cdr l) keys colls tag-prefix tags style title part-depth)]) + (make-part (part-tag-prefix part) + (part-tags part) + (part-title-content part) + (part-style part) + (part-to-collect part) + (make-flow (append para + (list (car l)) + (flow-paragraphs (part-flow part)))) + (part-parts part)))] [(part? (car l)) (let ([para (decode-accum-para accum)] - [part (decode-flow* (cdr l) keys tag style title part-depth)]) - (make-styled-part (part-tags part) - (part-title-content part) - (part-collected-info part) - (part-to-collect part) - (make-flow (append para - (flow-paragraphs - (part-flow part)))) - (cons (car l) (part-parts part)) - (styled-part-style part)))] + [part (decode-flow* (cdr l) keys colls tag-prefix tags style title part-depth)]) + (make-part (part-tag-prefix part) + (part-tags part) + (part-title-content part) + (part-style part) + (part-to-collect part) + (make-flow (append para + (flow-paragraphs + (part-flow part)))) + (cons (car l) (part-parts part))))] [(and (part-start? (car l)) (or (not part-depth) ((part-start-depth (car l)) . <= . part-depth))) @@ -138,54 +145,57 @@ (part? (car l)))) (let ([para (decode-accum-para accum)] [s (decode-styled-part (reverse s-accum) - (part-start-tag s) + (part-start-tag-prefix s) + (part-start-tags s) (part-start-style s) (part-start-title s) (add1 part-depth))] - [part (decode-flow* l keys tag style title part-depth)]) - (make-styled-part (part-tags part) - (part-title-content part) - (part-collected-info part) - (part-to-collect part) - (make-flow para) - (cons s (part-parts part)) - (styled-part-style part))) + [part (decode-flow* l keys colls tag-prefix tags style title part-depth)]) + (make-part (part-tag-prefix part) + (part-tags part) + (part-title-content part) + (part-style part) + (part-to-collect part) + (make-flow para) + (cons s (part-parts part)))) (if (splice? (car l)) (loop (append (splice-run (car l)) (cdr l)) s-accum) (loop (cdr l) (cons (car l) s-accum))))))] [(splice? (car l)) - (loop (append (splice-run (car l)) (cdr l)) next? keys accum title tag style)] - [(null? (cdr l)) (loop null #f keys (cons (car l) accum) title tag style)] + (loop (append (splice-run (car l)) (cdr l)) next? keys colls accum title tag-prefix tags style)] + [(null? (cdr l)) (loop null #f keys colls (cons (car l) accum) title tag-prefix tags style)] [(part-index-decl? (car l)) - (loop (cdr l) next? (cons (car l) keys) accum title tag style)] + (loop (cdr l) next? (cons (car l) keys) colls accum title tag-prefix tags style)] + [(part-collect-decl? (car l)) + (loop (cdr l) next? keys (cons (part-collect-decl-element (car l)) colls) accum title tag-prefix tags style)] [(and (pair? (cdr l)) (splice? (cadr l))) - (loop (cons (car l) (append (splice-run (cadr l)) (cddr l))) next? keys accum title tag style)] + (loop (cons (car l) (append (splice-run (cadr l)) (cddr l))) next? keys colls accum title tag-prefix tags style)] [(line-break? (car l)) (if next? - (loop (cdr l) #t keys accum title tag style) + (loop (cdr l) #t keys colls accum title tag-prefix tags style) (let ([m (match-newline-whitespace (cdr l))]) (if m - (let ([part (loop m #t keys null title tag style)]) - (make-styled-part (part-tags part) - (part-title-content part) - (part-collected-info part) - (part-to-collect part) - (make-flow (append (decode-accum-para accum) - (flow-paragraphs (part-flow part)))) - (part-parts part) - (styled-part-style part))) - (loop (cdr l) #f keys (cons (car l) accum) title tag style))))] - [else (loop (cdr l) #f keys (cons (car l) accum) title tag style)]))) + (let ([part (loop m #t keys colls null title tag-prefix tags style)]) + (make-part (part-tag-prefix part) + (part-tags part) + (part-title-content part) + (part-style part) + (part-to-collect part) + (make-flow (append (decode-accum-para accum) + (flow-paragraphs (part-flow part)))) + (part-parts part))) + (loop (cdr l) #f keys colls (cons (car l) accum) title tag-prefix tags style))))] + [else (loop (cdr l) #f keys colls (cons (car l) accum) title tag-prefix tags style)]))) - (define (decode-part l tag title depth) - (decode-flow* l null tag #f title depth)) + (define (decode-part l tags title depth) + (decode-flow* l null null #f tags #f title depth)) - (define (decode-styled-part l tag style title depth) - (decode-flow* l null tag style title depth)) + (define (decode-styled-part l tag-prefix tags style title depth) + (decode-flow* l null null tag-prefix tags style title depth)) (define (decode-flow l) - (part-flow (decode-flow* l null #f #f #f #f))) + (part-flow (decode-flow* l null null #f null #f #f #f))) (define (match-newline-whitespace l) (cond @@ -207,7 +217,7 @@ (loop (cdr l))))) (define (decode l) - (decode-part l #f #f 0)) + (decode-part l null #f 0)) (define (decode-paragraph l) (make-paragraph diff --git a/collects/scribble/doclang.ss b/collects/scribble/doclang.ss index 31eb64b0..61df31a4 100644 --- a/collects/scribble/doclang.ss +++ b/collects/scribble/doclang.ss @@ -43,7 +43,8 @@ (kernel-form-identifier-list #'here) (syntax->list #'(provide require - require-for-syntax))))]) + require-for-syntax + require-for-label))))]) (syntax-case expanded (begin) [(begin body1 ...) #`(doc-begin m-id exprs body1 ... . body)] @@ -53,6 +54,7 @@ (syntax->list #'(require provide require-for-syntax + require-for-label define-values define-syntaxes define-for-syntaxes)))) diff --git a/collects/scribble/html-render.ss b/collects/scribble/html-render.ss index 1e04b7b4..f4ce24eb 100644 --- a/collects/scribble/html-render.ss +++ b/collects/scribble/html-render.ss @@ -5,6 +5,8 @@ (lib "file.ss") (lib "list.ss") (lib "runtime-path.ss") + (lib "main-doc.ss" "setup") + (lib "main-collects.ss" "setup") (prefix xml: (lib "xml.ss" "xml"))) (provide render-mixin render-multi-mixin) @@ -15,12 +17,25 @@ (define current-subdirectory (make-parameter #f)) (define current-output-file (make-parameter #f)) + (define current-top-part (make-parameter #f)) (define on-separate-page (make-parameter #t)) (define next-separate-page (make-parameter #f)) (define collecting-sub (make-parameter 0)) (define current-no-links (make-parameter #f)) (define extra-breaking? (make-parameter #f)) + (define (path->relative p) + (let ([p (path->main-doc-relative p)]) + (if (path? p) + (path->main-collects-relative p) + p))) + + (define (relative->path p) + (let ([p (main-doc-relative->path p)]) + (if (path? p) + p + (main-collects-relative->path p)))) + ;; ---------------------------------------- ;; main mixin @@ -33,58 +48,57 @@ get-dest-directory format-number strip-aux - lookup quiet-table-of-contents) (define/override (get-suffix) #".html") ;; ---------------------------------------- - (define/override (collect ds fns) - (let ([ht (make-hash-table 'equal)]) - (map (lambda (d fn) - (parameterize ([current-output-file fn]) - (collect-part d #f ht null))) - ds - fns) - ht)) + (define/override (start-collect ds fns ci) + (map (lambda (d fn) + (parameterize ([current-output-file fn] + [current-top-part d]) + (collect-part d #f ci null))) + ds + fns)) - (define/public (part-whole-page? p ht) - (let ([dest (lookup p ht `(part ,(car (part-tags p))))]) + (define/public (part-whole-page? p ri) + (let ([dest (resolve-get p ri (car (part-tags p)))]) (caddr dest))) - (define/public (current-part-whole-page?) - #f) + (define/public (current-part-whole-page? d) + (eq? d (current-top-part))) - (define/override (collect-part-tags d ht number) + (define/override (collect-part-tags d ci number) (for-each (lambda (t) - (hash-table-put! ht - `(part ,t) - (list (current-output-file) - (part-title-content d) - (current-part-whole-page?)))) + (let ([key (generate-tag t ci)]) + (collect-put! ci + key + (list (path->relative (current-output-file)) + (or (part-title-content d) + '("???")) + (current-part-whole-page? d) + (format "~a" key))))) (part-tags d))) - (define/override (collect-target-element i ht) - (hash-table-put! ht - (target-element-tag i) - (list (current-output-file) - #f - (page-target-element? i)))) - + (define/override (collect-target-element i ci) + (let ([key (generate-tag (target-element-tag i) ci)]) + (collect-put! ci + key + (list (path->relative (current-output-file)) + #f + (page-target-element? i) + (format "~a" key))))) + ;; ---------------------------------------- (define/private (reveal-subparts? p) - (and (styled-part? p) - (let ([s (styled-part-style p)]) - (or (eq? s 'reveal) - (and (list? s) - (memq 'reveal s)))))) - - (define/public (render-toc-view d ht) + (part-style? p 'reveal)) + + (define/public (render-toc-view d ri) (let-values ([(top mine) (let loop ([d d][mine d]) - (let ([p (collected-info-parent (part-collected-info d))]) + (let ([p (collected-info-parent (part-collected-info d ri))]) (if p (loop p (if (reveal-subparts? d) mine @@ -95,7 +109,7 @@ (div ((class "tocviewtitle")) (a ((href "index.html") (class "tocviewlink")) - ,@(render-content (part-title-content top) d ht))) + ,@(render-content (or (part-title-content top) '("???")) d ri))) (div nbsp) (table ((class "tocviewlist") @@ -107,24 +121,24 @@ (td ((align "right")) ,@(if show-number? - (format-number (collected-info-number (part-collected-info p)) + (format-number (collected-info-number (part-collected-info p ri)) '((tt nbsp))) '("-" nbsp))) (td - (a ((href ,(let ([dest (lookup p ht `(part ,(car (part-tags p))))]) + (a ((href ,(let ([dest (resolve-get p ri (car (part-tags p)))]) (format "~a~a~a" - (from-root (car dest) + (from-root (relative->path (car dest)) (get-dest-directory)) (if (caddr dest) "" "#") (if (caddr dest) "" - `(part ,(car (part-tags p))))))) + (cadddr dest))))) (class ,(if (eq? p mine) "tocviewselflink" "tocviewlink"))) - ,@(render-content (part-title-content p) d ht)))))) + ,@(render-content (or (part-title-content p) '("???")) d ri)))))) (let loop ([l (map (lambda (v) (cons v #t)) (part-parts top))]) (cond [(null? l) null] @@ -133,92 +147,101 @@ (part-parts (caar l))) (cdr l))))] [else (cons (car l) (loop (cdr l)))]))))) - ,@(if (ormap (lambda (p) (part-whole-page? p ht)) (part-parts d)) - null - (let ([ps (cdr - (let flatten ([d d]) - (cons d - (apply - append - (letrec ([flow-targets - (lambda (flow) - (apply append (map flow-element-targets (flow-paragraphs flow))))] - [flow-element-targets - (lambda (e) - (cond - [(table? e) (table-targets e)] - [(paragraph? e) (para-targets e)] - [(itemization? e) - (apply append (map flow-targets (itemization-flows e)))] - [(blockquote? e) - (apply append (map flow-element-targets (blockquote-paragraphs e)))] - [(delayed-flow-element? e) - null]))] - [para-targets - (lambda (para) - (let loop ([c (paragraph-content para)]) - (cond - [(empty? c) null] - [else (let ([a (car c)]) - (cond - [(toc-target-element? a) - (cons a (loop (cdr c)))] - [(element? a) - (append (loop (element-content a)) - (loop (cdr c)))] - [(delayed-element? a) - (loop (cons (force-delayed-element a this d ht) - (cdr c)))] - [else - (loop (cdr c))]))])))] - [table-targets - (lambda (table) - (apply append - (map (lambda (flows) - (apply append (map (lambda (f) - (if (eq? f 'cont) - null - (flow-targets f))) - flows))) - (table-flowss table))))]) - (apply append (map flow-element-targets (flow-paragraphs (part-flow d))))) - (map flatten (part-parts d))))))]) - (if (null? ps) - null - `((div ((class "tocsub")) - (div ((class "tocsubtitle")) - "On this page:") - (table - ((class "tocsublist") - (cellspacing "0")) - ,@(map (lambda (p) - (parameterize ([current-no-links #t] - [extra-breaking? #t]) - `(tr - (td - ,@(if (part? p) - `((span ((class "tocsublinknumber")) - ,@(format-number (collected-info-number (part-collected-info p)) - '((tt nbsp))))) - '("")) - (a ((href ,(if (part? p) - (let ([dest (lookup p ht `(part ,(car (part-tags p))))]) - (format "#~a" - `(part ,(car (part-tags p))))) - (format "#~a" (target-element-tag p)))) - (class ,(if (part? p) - "tocsubseclink" - "tocsublink"))) - ,@(if (part? p) - (render-content (part-title-content p) d ht) - (render-content (element-content p) d ht))))))) - ps))))))) + ,@(render-onthispage-contents d ri top) ,@(apply append (map (lambda (t) - (render-table t d ht)) + (render-table t d ri)) (filter auxiliary-table? (flow-paragraphs (part-flow d))))))))) - (define/public (render-one-part d ht fn number) + (define/private (render-onthispage-contents d ri top) + (if (ormap (lambda (p) (part-whole-page? p ri)) + (part-parts d)) + null + (let* ([nearly-top? (lambda (d) + (eq? top (collected-info-parent (part-collected-info d ri))))] + [ps ((if (nearly-top? d) values cdr) + (let flatten ([d d]) + (apply + append + ;; don't include the section if it's in the TOC + (if (nearly-top? d) + null + (list d)) + ;; get internal targets: + (letrec ([flow-targets + (lambda (flow) + (apply append (map flow-element-targets (flow-paragraphs flow))))] + [flow-element-targets + (lambda (e) + (cond + [(table? e) (table-targets e)] + [(paragraph? e) (para-targets e)] + [(itemization? e) + (apply append (map flow-targets (itemization-flows e)))] + [(blockquote? e) + (apply append (map flow-element-targets (blockquote-paragraphs e)))] + [(delayed-flow-element? e) + null]))] + [para-targets + (lambda (para) + (let loop ([c (paragraph-content para)]) + (cond + [(empty? c) null] + [else (let ([a (car c)]) + (cond + [(toc-target-element? a) + (cons a (loop (cdr c)))] + [(element? a) + (append (loop (element-content a)) + (loop (cdr c)))] + [(delayed-element? a) + (loop (cons (delayed-element-content a ri) + (cdr c)))] + [else + (loop (cdr c))]))])))] + [table-targets + (lambda (table) + (apply append + (map (lambda (flows) + (apply append (map (lambda (f) + (if (eq? f 'cont) + null + (flow-targets f))) + flows))) + (table-flowss table))))]) + (apply append (map flow-element-targets (flow-paragraphs (part-flow d))))) + (map flatten (part-parts d)))))]) + (if (null? ps) + null + `((div ((class "tocsub")) + (div ((class "tocsubtitle")) + "On this page:") + (table + ((class "tocsublist") + (cellspacing "0")) + ,@(map (lambda (p) + (parameterize ([current-no-links #t] + [extra-breaking? #t]) + `(tr + (td + ,@(if (part? p) + `((span ((class "tocsublinknumber")) + ,@(format-number (collected-info-number + (part-collected-info p ri)) + '((tt nbsp))))) + '("")) + (a ((href ,(if (part? p) + (format "#~a" (tag-key (car (part-tags p)) ri)) + (format "#~a" (tag-key (target-element-tag p) ri)))) + (class ,(if (part? p) + "tocsubseclink" + "tocsublink"))) + ,@(if (part? p) + (render-content (or (part-title-content p) '("???")) d ri) + (render-content (element-content p) d ri))))))) + ps)))))))) + + (define/public (render-one-part d ri fn number) (parameterize ([current-output-file fn]) (let ([xpr `(html () (head @@ -226,32 +249,28 @@ (content "text-html; charset=utf-8"))) ,@(let ([c (part-title-content d)]) (if c - `((title ,@(format-number number '(nbsp)) ,(content->string c this d ht))) + `((title ,@(format-number number '(nbsp)) ,(content->string c this d ri))) null)) (link ((rel "stylesheet") (type "text/css") (href "scribble.css") (title "default")))) - (body ,@(render-toc-view d ht) - (div ((class "main")) ,@(render-part d ht))))]) + (body ,@(render-toc-view d ri) + (div ((class "main")) ,@(render-part d ri))))]) (install-file scribble-css) (xml:write-xml/content (xml:xexpr->xml xpr))))) - (define/override (render-one d ht fn) - (render-one-part d ht fn null)) + (define/override (render-one d ri fn) + (render-one-part d ri fn null)) - (define/override (render-part d ht) - (let ([number (collected-info-number (part-collected-info d))]) + (define/override (render-part d ri) + (let ([number (collected-info-number (part-collected-info d ri))]) `(,@(if (and (not (part-title-content d)) (null? number)) null - (if (and (styled-part? d) - (let ([s (styled-part-style d)]) - (or (eq? s 'hidden) - (and (list? s) - (memq 'hidden s))))) + (if (part-style? d 'hidden) (map (lambda (t) - `(a ((name ,(format "~a" `(part ,t)))))) + `(a ((name ,(format "~a" (tag-key t ri)))))) (part-tags d)) `((,(case (length number) [(0) 'h2] @@ -260,21 +279,21 @@ [else 'h5]) ,@(format-number number '((tt nbsp))) ,@(map (lambda (t) - `(a ((name ,(format "~a" `(part ,t)))))) + `(a ((name ,(format "~a" (tag-key t ri)))))) (part-tags d)) ,@(if (part-title-content d) - (render-content (part-title-content d) d ht) + (render-content (part-title-content d) d ri) null))))) - ,@(render-flow* (part-flow d) d ht #f) + ,@(render-flow* (part-flow d) d ri #f) ,@(let loop ([pos 1] [secs (part-parts d)]) (if (null? secs) null (append - (render-part (car secs) ht) + (render-part (car secs) ri) (loop (add1 pos) (cdr secs)))))))) - (define/private (render-flow* p part ht special-last?) + (define/private (render-flow* p part ri special-last?) ;; Wrap each table with

, except for a trailing table ;; when `special-last?' is #t (let loop ([f (flow-paragraphs p)]) @@ -283,71 +302,78 @@ [(and (table? (car f)) (or (not special-last?) (not (null? (cdr f))))) - (cons `(p ,@(render-flow-element (car f) part ht)) + (cons `(p ,@(render-flow-element (car f) part ri)) (loop (cdr f)))] [else - (append (render-flow-element (car f) part ht) + (append (render-flow-element (car f) part ri) (loop (cdr f)))]))) - (define/override (render-flow p part ht) - (render-flow* p part ht #t)) + (define/override (render-flow p part ri) + (render-flow* p part ri #t)) - (define/override (render-paragraph p part ht) + (define/override (render-paragraph p part ri) `((p ,@(if (styled-paragraph? p) `(((class ,(styled-paragraph-style p)))) null) - ,@(super render-paragraph p part ht)))) + ,@(super render-paragraph p part ri)))) - (define/override (render-element e part ht) + (define/override (render-element e part ri) (cond + [(hover-element? e) + `((span ((title ,(hover-element-text e))) ,@(render-plain-element e part ri)))] [(target-element? e) - `((a ((name ,(target-element-tag e)))) - ,@(render-plain-element e part ht))] + `((a ((name ,(format "~a" (tag-key (target-element-tag e) ri))))) + ,@(render-plain-element e part ri))] [(and (link-element? e) (not (current-no-links))) (parameterize ([current-no-links #t]) - (let ([dest (lookup part ht (link-element-tag e))]) + (let ([dest (resolve-get part ri (link-element-tag e))]) (if dest `((a ((href ,(format "~a~a~a" - (from-root (car dest) + (from-root (relative->path (car dest)) (get-dest-directory)) (if (caddr dest) "" "#") (if (caddr dest) "" - (link-element-tag e)))) + (cadddr dest)))) ,@(if (string? (element-style e)) `((class ,(element-style e))) null)) ,@(if (null? (element-content e)) - (render-content (strip-aux (cadr dest)) part ht) - (render-content (element-content e) part ht)))) - (begin (fprintf (current-error-port) "Undefined link: ~s~n" (link-element-tag e)) ; XXX Add source info - `((font ((class "badlink")) - ,@(if (null? (element-content e)) - `(,(format "~s" (link-element-tag e))) - (render-plain-element e part ht))))))))] - [else (render-plain-element e part ht)])) + (render-content (strip-aux (cadr dest)) part ri) + (render-content (element-content e) part ri)))) + (begin + (when #f + (fprintf (current-error-port) + "Undefined link: ~s~n" + (tag-key (link-element-tag e) ri))) + `((font ((class "badlink")) + ,@(if (null? (element-content e)) + `(,(format "~s" (tag-key (link-element-tag e) ri))) + (render-plain-element e part ri))))))))] + [else (render-plain-element e part ri)])) - (define/private (render-plain-element e part ht) + (define/private (render-plain-element e part ri) (let ([style (and (element? e) (element-style e))]) (cond [(symbol? style) (case style - [(italic) `((i ,@(super render-element e part ht)))] - [(bold) `((b ,@(super render-element e part ht)))] - [(tt) `((tt ,@(super render-element e part ht)))] - [(sf) `((b (font ([size "-1"][face "Helvetica"]) ,@(super render-element e part ht))))] - [(subscript) `((sub ,@(super render-element e part ht)))] - [(superscript) `((sup ,@(super render-element e part ht)))] + [(italic) `((i ,@(super render-element e part ri)))] + [(bold) `((b ,@(super render-element e part ri)))] + [(tt) `((tt ,@(super render-element e part ri)))] + [(no-break) `((span ([class "nobreak"]) ,@(super render-element e part ri)))] + [(sf) `((b (font ([size "-1"][face "Helvetica"]) ,@(super render-element e part ri))))] + [(subscript) `((sub ,@(super render-element e part ri)))] + [(superscript) `((sup ,@(super render-element e part ri)))] [(hspace) `((span ([class "hspace"]) ,@(let ([str (content->string (element-content e))]) (map (lambda (c) 'nbsp) (string->list str)))))] [else (error 'html-render "unrecognized style symbol: ~e" style)])] [(string? style) - `((span ([class ,style]) ,@(super render-element e part ht)))] + `((span ([class ,style]) ,@(super render-element e part ri)))] [(and (pair? style) (eq? (car style) 'show-color)) `((font ((style ,(format "background-color: ~a" @@ -357,16 +383,16 @@ (cdr style)))))) (tt nbsp nbsp nbsp nbsp nbsp)) nbsp - ,@(super render-element e part ht))] + ,@(super render-element e part ri))] [(target-url? style) (if (current-no-links) - (super render-element e part ht) + (super render-element e part ri) (parameterize ([current-no-links #t]) - `((a ((href ,(target-url-addr style))) ,@(super render-element e part ht)))))] + `((a ((href ,(target-url-addr style))) ,@(super render-element e part ri)))))] [(image-file? style) `((img ((src ,(install-file (image-file-path style))))))] - [else (super render-element e part ht)]))) + [else (super render-element e part ri)]))) - (define/override (render-table t part ht) + (define/override (render-table t part ri) `((table ((cellspacing "0") ,@(case (table-style t) [(boxed) '((class "boxed"))] @@ -423,36 +449,36 @@ [(eq? 'cont (car ds)) (loop (+ n 1) (cdr ds))] [else n]))))) null)) - ,@(render-flow d part ht)) + ,@(render-flow d part ri)) (loop (cdr ds) (cdr as) (cdr vas))))))))) (table-flowss t) (cdr (or (and (list? (table-style t)) (assoc 'row-styles (or (table-style t) null))) (cons #f (map (lambda (x) #f) (table-flowss t))))))))) - (define/override (render-blockquote t part ht) + (define/override (render-blockquote t part ri) `((blockquote ,@(if (string? (blockquote-style t)) `(((class ,(blockquote-style t)))) null) ,@(apply append (map (lambda (i) - (render-flow-element i part ht)) + (render-flow-element i part ri)) (blockquote-paragraphs t)))))) - (define/override (render-itemization t part ht) + (define/override (render-itemization t part ri) `((ul ,@(map (lambda (flow) - `(li ,@(render-flow flow part ht))) + `(li ,@(render-flow flow part ri))) (itemization-flows t))))) - (define/override (render-other i part ht) + (define/override (render-other i part ri) (cond [(string? i) (let ([m (and (extra-breaking?) (regexp-match-positions #rx":" i))]) (if m (list* (substring i 0 (cdar m)) `(span ((class "mywbr")) " ") - (render-other (substring i (cdar m)) part ht)) + (render-other (substring i (cdar m)) part ri)) (list i)))] [(eq? i 'mdash) `(" " ndash " ")] [(eq? i 'hline) `((hr))] @@ -470,7 +496,9 @@ (class % (inherit render-one render-one-part - render-content) + render-content + part-whole-page? + format-number) (define/override (get-suffix) #"") @@ -479,10 +507,16 @@ (current-subdirectory)) (super get-dest-directory))) - (define/private (derive-filename d ht) + (define/private (derive-filename d) (let ([fn (format "~a.html" (regexp-replace* "[^-a-zA-Z0-9_=]" - (format "~a" (car (part-tags d))) + (let ([s (cadr (car (part-tags d)))]) + (if (string? s) + s + (if (part-title-content d) + (content->string (part-title-content d)) + ;; last-ditch effort to make up a unique name: + (format "???~a" (eq-hash-code d))))) "_"))]) (when ((string-length fn) . >= . 48) (error "file name too long (need a tag):" fn)) @@ -493,28 +527,25 @@ (build-path fn "index.html")) fns))) - (define/override (current-part-whole-page?) + (define/override (current-part-whole-page? d) ((collecting-sub) . <= . 2)) (define/private (toc-part? d) - (and (styled-part? d) - (let ([st (styled-part-style d)]) - (or (eq? 'toc st) - (and (list? st) (memq 'toc st)))))) + (part-style? d 'toc)) - (define/override (collect-part d parent ht number) + (define/override (collect-part d parent ci number) (let ([prev-sub (collecting-sub)]) (parameterize ([collecting-sub (if (toc-part? d) 1 (add1 prev-sub))]) (if (= 1 prev-sub) - (let ([filename (derive-filename d ht)]) + (let ([filename (derive-filename d)]) (parameterize ([current-output-file (build-path (path-only (current-output-file)) filename)]) - (super collect-part d parent ht number))) - (super collect-part d parent ht number))))) + (super collect-part d parent ci number))) + (super collect-part d parent ci number))))) - (define/override (render ds fns ht) + (define/override (render ds fns ri) (map (lambda (d fn) (printf " [Output to ~a/index.html]\n" fn) (unless (directory-exists? fn) @@ -523,7 +554,7 @@ (let ([fn (build-path fn "index.html")]) (with-output-to-file fn (lambda () - (render-one d ht fn)) + (render-one d ri fn)) 'truncate/replace)))) ds fns)) @@ -538,8 +569,8 @@ (inherit render-table) - (define/private (find-siblings d) - (let ([parent (collected-info-parent (part-collected-info d))]) + (define/private (find-siblings d ri) + (let ([parent (collected-info-parent (part-collected-info d ri))]) (let loop ([l (if parent (part-parts parent) (if (null? (part-parts d)) @@ -552,12 +583,12 @@ (cadr l)))] [else (loop (cdr l) (car l))])))) - (define/private (part-parent d) - (collected-info-parent (part-collected-info d))) + (define/private (part-parent d ri) + (collected-info-parent (part-collected-info d ri))) - (define/private (navigation d ht) - (let ([parent (part-parent d)]) - (let*-values ([(prev next) (find-siblings d)] + (define/private (navigation d ri) + (let ([parent (part-parent d ri)]) + (let*-values ([(prev next) (find-siblings d ri)] [(prev) (if prev (let loop ([prev prev]) (if (and (toc-part? prev) @@ -575,17 +606,17 @@ parent (toc-part? parent)) (let-values ([(prev next) - (find-siblings parent)]) + (find-siblings parent ri)]) next)] [else next])] [(index) (let loop ([d d]) - (let ([p (part-parent d)]) + (let ([p (part-parent d ri)]) (if p (loop p) (let ([subs (part-parts d)]) (and (pair? subs) (let ([d (car (last-pair subs))]) - (and (equal? '("Index") (part-title-content d)) + (and (part-style? d 'index) d)))))))]) `(,@(render-table (make-table 'at-left @@ -614,9 +645,9 @@ (make-link-element #f index-content - `(part ,(car (part-tags index)))))))))) + (car (part-tags index))))))))) null)))) - d ht) + d ri) ,@(render-table (make-table 'at-right (list @@ -628,7 +659,7 @@ (make-element (if parent (make-target-url (if prev - (derive-filename prev ht) + (derive-filename prev) "index.html")) "nonavigation") prev-content) @@ -637,34 +668,34 @@ (if parent (make-target-url (if (toc-part? parent) - (derive-filename parent ht) + (derive-filename parent) "index.html")) "nonavigation") up-content) sep-element (make-element (if next - (make-target-url (derive-filename next ht)) + (make-target-url (derive-filename next)) "nonavigation") next-content)))))))) d - ht))))) + ri))))) - (define/override (render-part d ht) - (let ([number (collected-info-number (part-collected-info d))]) + (define/override (render-part d ri) + (let ([number (collected-info-number (part-collected-info d ri))]) (cond [(and (not (on-separate-page)) (or (= 1 (length number)) (next-separate-page))) ;; Render as just a link, and put the actual ;; content in a new file: - (let* ([filename (derive-filename d ht)] + (let* ([filename (derive-filename d)] [full-path (build-path (path-only (current-output-file)) filename)]) (parameterize ([on-separate-page #t]) (with-output-to-file full-path (lambda () - (render-one-part d ht full-path number)) + (render-one-part d ri full-path number)) 'truncate/replace) null))] [else @@ -673,14 +704,14 @@ [on-separate-page #f]) (if sep? ;; Navigation bars; - `(,@(navigation d ht) + `(,@(navigation d ri) (p nbsp) - ,@(super render-part d ht) + ,@(super render-part d ri) (p nbsp) - ,@(navigation d ht) + ,@(navigation d ri) (p nbsp)) ;; Normal section render - (super render-part d ht))))]))) + (super render-part d ri))))]))) (super-new))) diff --git a/collects/scribble/latex-render.ss b/collects/scribble/latex-render.ss index c439a1b3..57dcc9bc 100644 --- a/collects/scribble/latex-render.ss +++ b/collects/scribble/latex-render.ss @@ -18,13 +18,12 @@ render-flow-element render-content install-file - format-number - lookup) + format-number) (define (define-color s s2) (printf "\\newcommand{\\~a}[1]{{\\mytexttt{\\color{~a}{#1}}}}\n" s s2)) - (define/override (render-one d ht fn) + (define/override (render-one d ri fn) (printf "\\documentclass{article}\n") (printf "\\parskip=10pt%\n") (printf "\\parindent=0pt%\n") @@ -75,17 +74,16 @@ (printf "\\begin{document}\n\\sloppy\n") (when (part-title-content d) (printf "\\title{") - (render-content (part-title-content d) d ht) + (render-content (part-title-content d) d ri) (printf "}\\maketitle\n")) - (render-part d ht) + (render-part d ri) (printf "\\end{document}\n")) - (define/override (render-part d ht) - (let ([number (collected-info-number (part-collected-info d))]) + (define/override (render-part d ri) + (let ([number (collected-info-number (part-collected-info d ri))]) (when (and (part-title-content d) (pair? number)) - (when (and (styled-part? d) - (eq? 'index (styled-part-style d))) + (when (part-style? d 'index) (printf "\\twocolumn\n\\parskip=0pt\n\\addcontentsline{toc}{section}{Index}\n")) (printf "\\~a~a{" (case (length number) @@ -97,20 +95,19 @@ (not (car number))) "*" "")) - (render-content (part-title-content d) d ht) + (render-content (part-title-content d) d ri) (printf "}") - (when (and (styled-part? d) - (eq? 'index (styled-part-style d))) + (when (part-style? d 'index) (printf "\n\n"))) (for-each (lambda (t) - (printf "\\label{t:~a}" (t-encode `(part ,t)))) + (printf "\\label{t:~a}" (t-encode (tag-key t ri)))) (part-tags d)) - (render-flow (part-flow d) d ht) - (for-each (lambda (sec) (render-part sec ht)) + (render-flow (part-flow d) d ri) + (for-each (lambda (sec) (render-part sec ri)) (part-parts d)) null)) - (define/override (render-paragraph p part ht) + (define/override (render-paragraph p part ri) (printf "\n\n") (let ([margin? (and (styled-paragraph? p) (equal? "refpara" (styled-paragraph-style p)))]) @@ -118,28 +115,35 @@ (printf "\\marginpar{\\footnotesize ")) (if (toc-paragraph? p) (printf "\\newpage \\tableofcontents \\newpage") - (super render-paragraph p part ht)) + (super render-paragraph p part ri)) (when margin? (printf "}"))) (printf "\n\n") null) - (define/override (render-element e part ht) + (define/override (render-element e part ri) (let ([part-label? (and (link-element? e) (pair? (link-element-tag e)) (eq? 'part (car (link-element-tag e))) (null? (element-content e)))]) (parameterize ([show-link-page-numbers #f]) (when (target-element? e) - (printf "\\label{t:~a}" (t-encode (target-element-tag e)))) + (printf "\\label{t:~a}" (t-encode (tag-key (target-element-tag e) ri)))) (when part-label? (printf "\\S") - (render-content (let ([dest (lookup part ht (link-element-tag e))]) + (render-content (let ([dest (resolve-get part ri (link-element-tag e))]) (if dest - (format-number (cadr dest) null) + (if (list? (cadr dest)) + (format-number (cadr dest) null) + (begin + (fprintf (current-error-port) + "Internal tag error: ~s -> ~s\n" + (link-element-tag e) + dest) + '("!!!"))) (list "???"))) part - ht) + ri) (printf " ``")) (let ([style (and (element? e) (element-style e))] @@ -147,7 +151,7 @@ (printf "{\\~a{" s) (parameterize ([rendering-tt (or tt? (rendering-tt))]) - (super render-element e part ht)) + (super render-element e part ri)) (printf "}}"))]) (cond [(symbol? style) @@ -155,6 +159,7 @@ [(italic) (wrap e "textit" #f)] [(bold) (wrap e "textbf" #f)] [(tt) (wrap e "mytexttt" #t)] + [(nobreak) (super render-element e part ri)] [(sf) (wrap e "textsf" #f)] [(subscript) (wrap e "textsub" #f)] [(superscript) (wrap e "textsuper" #f)] @@ -170,12 +175,12 @@ [(image-file? style) (let ([fn (install-file (image-file-path style))]) (printf "\\includegraphics{~a}" fn))] - [else (super render-element e part ht)]))) + [else (super render-element e part ri)]))) (when part-label? (printf "''")) (when (and (link-element? e) (show-link-page-numbers)) - (printf ", \\pageref{t:~a}" (t-encode (link-element-tag e)))) + (printf ", \\pageref{t:~a}" (t-encode (tag-key (link-element-tag e) ri)))) null)) (define/private (t-encode s) @@ -192,7 +197,7 @@ (format "x~x" (char->integer c))])) (string->list (format "~s" s))))) - (define/override (render-table t part ht) + (define/override (render-table t part ri) (let* ([boxed? (eq? 'boxed (table-style t))] [index? (eq? 'index (table-style t))] [inline? (and (not boxed?) @@ -262,7 +267,7 @@ [else n]))]) (unless (= cnt 1) (printf "\\multicolumn{~a}{l}{" cnt)) - (render-flow (car flows) part ht) + (render-flow (car flows) part ri) (unless (= cnt 1) (printf "}")) (unless (null? (list-tail flows cnt)) @@ -284,25 +289,25 @@ "")))))) null) - (define/override (render-itemization t part ht) + (define/override (render-itemization t part ri) (printf "\n\n\\begin{itemize}\n") (for-each (lambda (flow) (printf "\n\n\\item ") - (render-flow flow part ht)) + (render-flow flow part ri)) (itemization-flows t)) (printf "\n\n\\end{itemize}\n") null) - (define/override (render-blockquote t part ht) + (define/override (render-blockquote t part ri) (printf "\n\n\\begin{quote}\n") (parameterize ([current-table-mode (list "blockquote" t)]) (for-each (lambda (e) - (render-flow-element e part ht)) + (render-flow-element e part ri)) (blockquote-paragraphs t))) (printf "\n\n\\end{quote}\n") null) - (define/override (render-other i part ht) + (define/override (render-other i part ri) (cond [(string? i) (display-protected i)] [(symbol? i) (display @@ -362,11 +367,11 @@ ;; ---------------------------------------- - (define/override (table-of-contents sec ht) + (define/override (table-of-contents sec ri) ;; FIXME: isn't local to the section (make-toc-paragraph null)) - (define/override (local-table-of-contents part ht) + (define/override (local-table-of-contents part ri) (make-paragraph null)) ;; ---------------------------------------- diff --git a/collects/scribble/manual.ss b/collects/scribble/manual.ss index 2833ca2b..29e17708 100644 --- a/collects/scribble/manual.ss +++ b/collects/scribble/manual.ss @@ -10,6 +10,8 @@ (lib "class.ss") (lib "stxparam.ss")) (require-for-syntax (lib "stxparam.ss")) + (require-for-label (lib "lang.ss" "big") + (lib "class.ss")) (provide (all-from "basic.ss")) @@ -50,10 +52,24 @@ (define (to-element/id s) (make-element "schemesymbol" (list (to-element/no-color s)))) - (define (keep-s-expr ctx s v) + (define-syntax (keep-s-expr stx) + (syntax-case stx () + [(_ ctx s srcloc) + (let ([sv (syntax-e #'s)]) + (if (or (number? sv) + (boolean? sv) + (and (pair? sv) + (identifier? (car sv)) + (module-identifier=? #'cons (car sv)))) + ;; We know that the context is irrelvant + #'s + ;; Context may be relevant: + #'(*keep-s-expr s ctx)))])) + (define (*keep-s-expr s ctx) (if (symbol? s) (make-just-context s ctx) s)) + (define (add-sq-prop s name val) (if (eq? name 'paren-shape) (make-shaped-parens s val) @@ -158,9 +174,9 @@ (define (exec . str) (make-element 'tt (decode-content str))) (define (Flag . str) - (make-element 'tt (cons "-" (decode-content str)))) + (make-element 'no-break (list (make-element 'tt (cons "-" (decode-content str)))))) (define (DFlag . str) - (make-element 'tt (cons "--" (decode-content str)))) + (make-element 'no-break (list (make-element 'tt (cons "--" (decode-content str)))))) (define (envvar . str) (make-element 'tt (decode-content str))) (define (indexed-envvar . str) @@ -198,9 +214,8 @@ (elem (method a b) " in " (scheme a))])) (define (*method sym id) - (let ([tag (format "~a::~a" - (register-scheme-definition id) - sym)]) + (let ([tag (method-tag (register-scheme-definition id #t) + sym)]) (make-element "schemesymbol" (list (make-link-element @@ -208,6 +223,9 @@ (list (symbol->string sym)) tag))))) + (define (method-tag vtag sym) + (list 'meth + (format "~a::~a" (cadr vtag) sym))) ;; ---------------------------------------- @@ -222,7 +240,7 @@ (provide deftech tech techlink) - (define (*tech make-elem style s) + (define (*tech make-elem style doc s) (let* ([c (decode-content s)] [s (regexp-replace* #px"[-\\s]+" (regexp-replace @@ -235,26 +253,27 @@ " ")]) (make-elem style c - (format "tech-term:~a" s)))) + (list 'tech (doc-prefix doc s))))) (define (deftech . s) (let* ([e (apply defterm s)] - [t (*tech make-target-element #f (list e))]) + [t (*tech make-target-element #f #f (list e))]) (make-index-element #f (list t) (target-element-tag t) (list (element->string e)) (list e)))) - (define (tech . s) - (*tech make-link-element "techlink" s)) + (define (tech #:doc [doc #f] . s) + (*tech make-link-element "techlink" doc s)) - (define (techlink . s) - (*tech make-link-element #f s)) + (define (techlink #:doc [doc #f] . s) + (*tech make-link-element #f doc s)) ;; ---------------------------------------- - (provide defproc defproc* defstruct defthing defparam defboolparam + (provide declare-exporting + defproc defproc* defstruct defthing defparam defboolparam defform defform* defform/subs defform*/subs defform/none defidform specform specform/subs @@ -262,6 +281,33 @@ schemegrammar schemegrammar* var svar void-const undefined-const) + (define-syntax declare-exporting + (syntax-rules () + [(_ lib ...) (*declare-exporting '(lib ...))])) + + (define (*declare-exporting libs) + (make-part-collect-decl + (make-collect-element #f + null + (lambda (ri) + (collect-put! ri '(exporting-libraries #f)libs))))) + + (define-syntax (quote-syntax/loc stx) + (syntax-case stx () + [(_ id) + (with-syntax ([loc + (let ([s #'id]) + (list (syntax-source s) + (syntax-line s) + (syntax-column s) + (syntax-position s) + (syntax-span s)))]) + #'(let ([s (quote-syntax id)]) + (datum->syntax-object s + (syntax-e s) + 'loc + s)))])) + (define void-const (schemeresultfont "#")) (define undefined-const @@ -304,13 +350,13 @@ (syntax-rules () [(_ (id arg ...) result desc ...) (defproc* [[(id arg ...) result]] desc ...)])) - (define-syntax defproc* + (define-syntax defproc* (syntax-rules () [(_ [[(id arg ...) result] ...] desc ...) (defproc* #:mode procedure #:within #f [[(id arg ...) result] ...] desc ...)] [(_ #:mode m #:within cl [[(id arg ...) result] ...] desc ...) - (*defproc 'm (quote-syntax cl) - (list (quote-syntax id) ...) + (*defproc 'm (quote-syntax/loc cl) + (list (quote-syntax/loc id) ...) '[(id arg ...) ...] (list (list (lambda () (arg-contract arg)) ...) ...) (list (lambda () (schemeblock0 result)) ...) @@ -328,7 +374,7 @@ (define-syntax **defstruct (syntax-rules () [(_ name ([field field-contract] ...) immutable? transparent? desc ...) - (*defstruct (quote-syntax name) 'name + (*defstruct (quote-syntax/loc name) 'name '([field field-contract] ...) (list (lambda () (schemeblock0 field-contract)) ...) #t #t (lambda () (list desc ...)))])) (define-syntax (defform*/subs stx) @@ -347,7 +393,7 @@ [spec-id (syntax-case #'spec () [(name . rest) #'name])]) - #'(*defforms (quote-syntax spec-id) '(lit ...) + #'(*defforms (quote-syntax/loc spec-id) '(lit ...) '(spec spec1 ...) (list (lambda (x) (schemeblock0 new-spec)) (lambda (ignored) (schemeblock0 spec1)) ...) @@ -381,7 +427,7 @@ (define-syntax (defidform stx) (syntax-case stx () [(_ spec-id desc ...) - #'(*defforms (quote-syntax spec-id) null + #'(*defforms (quote-syntax/loc spec-id) null '(spec-id) (list (lambda (x) (make-paragraph (list x)))) null @@ -440,7 +486,7 @@ (define-syntax defthing (syntax-rules () [(_ id result desc ...) - (*defthing (quote-syntax id) 'id (quote-syntax result) (lambda () (list desc ...)))])) + (*defthing (quote-syntax/loc id) 'id (quote-syntax result) (lambda () (list desc ...)))])) (define-syntax defparam (syntax-rules () [(_ id arg contract desc ...) @@ -494,6 +540,27 @@ type-sym) "")))) + (define (annote-exporting-library e) + (make-delayed-element + (lambda (render p ri) + (let ([from (resolve-get p ri '(exporting-libraries #f))]) + (if (and from + (pair? from)) + (list (make-hover-element + #f + (list e) + (string-append + "Provided from: " + (let loop ([from from]) + (if (null? (cdr from)) + (format "~s" (car from)) + (format "~s, ~a" + (car from) + (loop (cdr from)))))))) + (list e)))) + (lambda () e) + (lambda () e))) + (define (*defproc mode within-id stx-ids prototypes arg-contractss result-contracts content-thunk) (let ([spacer (hspace 1)] @@ -589,34 +656,40 @@ (hspace 1) (if first? (let* ([mname (car prototype)] - [tag (format "~a::~a" - (register-scheme-definition within-id) - mname)] + [ctag (register-scheme-definition within-id #t)] + [tag (method-tag ctag mname)] [content (list (*method mname within-id))]) - (make-toc-target-element - #f - (list (make-index-element #f - content - tag - (list (symbol->string mname)) - content)) - tag)) + (if tag + (make-toc-target-element + #f + (list (make-index-element #f + content + tag + (list (symbol->string mname)) + content)) + tag) + (car content))) (*method (car prototype) within-id))))] [else (if first? - (let ([tag (register-scheme-definition stx-id)] - [content (list (to-element (make-just-context (car prototype) - stx-id)))]) - (make-toc-target-element - #f - (list (make-index-element #f - content - tag - (list (symbol->string (car prototype))) - content)) - tag)) - (to-element (make-just-context (car prototype) - stx-id)))])] + (let ([tag (register-scheme-definition stx-id #t)] + [content (list + (annote-exporting-library + (to-element (make-just-context (car prototype) + stx-id))))]) + (if tag + (make-toc-target-element + #f + (list (make-index-element #f + content + tag + (list (symbol->string (car prototype))) + content)) + tag) + (car content))) + (annote-exporting-library + (to-element (make-just-context (car prototype) + stx-id))))])] [(flat-size) (+ (prototype-size (cdr prototype) + +) (element-width tagged))] [(short?) (or (flat-size . < . 40) @@ -799,16 +872,19 @@ (register-scheme-definition (datum->syntax-object stx-id (string->symbol - name)))]) - (inner-make-target-element - #f - (list - (make-index-element #f - (list content) - tag - (list name) - (list (schemeidfont (make-element "schemevaluelink" (list name)))))) - tag)) + name)) + #t)]) + (if tag + (inner-make-target-element + #f + (list + (make-index-element #f + (list content) + tag + (list name) + (list (schemeidfont (make-element "schemevaluelink" (list name)))))) + tag) + content)) (cdr wrappers)))) (define (*defstruct stx-id name fields field-contracts immutable? transparent? content-thunk) @@ -826,9 +902,10 @@ (make-target-element* make-toc-target-element stx-id - (to-element (if (pair? name) - (make-just-context (car name) stx-id) - stx-id)) + (annote-exporting-library + (to-element (if (pair? name) + (make-just-context (car name) stx-id) + stx-id))) (let ([name (if (pair? name) (car name) name)]) @@ -975,16 +1052,19 @@ (list (make-flow (list (make-paragraph - (list (let ([tag (register-scheme-definition stx-id)] - [content (list (to-element (make-just-context name stx-id)))]) - (make-toc-target-element - #f - (list (make-index-element #f - content - tag - (list (symbol->string name)) - content)) - tag)) + (list (let ([tag (register-scheme-definition stx-id #t)] + [content (list (annote-exporting-library + (to-element (make-just-context name stx-id))))]) + (if tag + (make-toc-target-element + #f + (list (make-index-element #f + content + tag + (list (symbol->string name)) + content)) + tag) + (car content))) spacer ":" spacer (to-element result-contract)))))))) (content-thunk)))) @@ -1026,25 +1106,32 @@ (make-paragraph (list (to-element - `(,x - . ,(cdr form))))))) + `(,x . ,(cdr form))))))) (and kw-id (eq? form (car forms)) - (let ([tag (register-scheme-form-definition kw-id)] - [content (list (to-element (make-just-context (if (pair? form) - (car form) - form) - kw-id)))]) - (make-toc-target-element - #f - (if kw-id - (list (make-index-element #f - content - tag - (list (symbol->string (syntax-e kw-id))) - content)) - content) - tag)))))))) + (let ([tag (register-scheme-definition kw-id #t)] + [stag (register-scheme-form-definition kw-id)] + [content (list (annote-exporting-library + (to-element (make-just-context (if (pair? form) + (car form) + form) + kw-id))))]) + (if tag + (make-toc-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)) + content) + tag)) + stag) + (car content))))))))) forms form-procs) (if (null? sub-procs) null @@ -1156,17 +1243,25 @@ (make-paragraph (list (hspace 2) (apply tt s)))) (define (elemtag t . body) - (make-target-element #f (decode-content body) t)) + (make-target-element #f (decode-content body) `(elem ,t))) (define (elemref t . body) - (make-link-element #f (decode-content body) t)) + (make-link-element #f (decode-content body) `(elem ,t))) (provide elemtag elemref) - (define (secref s) - (make-link-element #f null `(part ,s))) - (define (seclink tag . s) - (make-link-element #f (decode-content s) `(part ,tag))) + (define (doc-prefix doc s) + (if doc + (format "~a:~a" + (module-path-prefix->string doc) + s) + s)) + + (define (secref s #:doc [doc #f]) + (make-link-element #f null `(part ,(doc-prefix doc s)))) + (define (seclink tag #:doc [doc #f] . s) + (make-link-element #f (decode-content s) `(part ,(doc-prefix doc tag)))) (define (*schemelink stx-id id . s) - (make-link-element #f (decode-content s) (register-scheme-definition stx-id))) + (make-link-element #f (decode-content s) (or (register-scheme-definition stx-id) + (format "--UNDEFINED:~a--" (syntax-e stx-id))))) (define-syntax schemelink (syntax-rules () [(_ id . content) (*schemelink (quote-syntax id) 'id . content)])) @@ -1261,7 +1356,7 @@ (define id val)))])) (define-syntax (class-doc-info stx) - (syntax-case stx (object%) + (syntax-case* stx (object%) module-label-identifier=? [(_ object%) #'#f] [(_ id) (class-id->class-doc-info-id #'id)])) @@ -1357,18 +1452,22 @@ (list (make-flow (list (make-paragraph - (list (let ([tag (register-scheme-definition stx-id)] - [content (list (to-element stx-id))]) - ((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)) - tag)) + (list (let ([tag (register-scheme-definition 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 + (if whole-page? + content ; title is already an index entry + (list (make-index-element #f + content + tag + (list (symbol->string (syntax-e stx-id))) + content))) + tag) + (car content))) spacer ":" spacer (if super (scheme class?) @@ -1403,12 +1502,12 @@ [(_ name super (intf ...) body ...) (define-class-doc-info name (syntax-parameterize ([current-class (quote-syntax name)]) - (register-class (quote-syntax name) + (register-class (quote-syntax/loc name) (class-doc-info super) (list (class-doc-info intf) ...) (lambda (whole-page?) (list - (*defclass (quote-syntax name) + (*defclass (quote-syntax/loc name) (quote-syntax super) (list (quote-syntax intf) ...) whole-page?))) @@ -1419,12 +1518,12 @@ [(_ name (intf ...) body ...) (define-class-doc-info name (syntax-parameterize ([current-class (quote-syntax name)]) - (register-class (quote-syntax name) + (register-class (quote-syntax/loc name) #f (list (class-doc-info intf) ...) (lambda (whole-page?) (list - (*defclass (quote-syntax name) + (*defclass (quote-syntax/loc name) #f (list (quote-syntax intf) ...) whole-page?))) diff --git a/collects/scribble/run.ss b/collects/scribble/run.ss index 2c0cde96..c7871114 100644 --- a/collects/scribble/run.ss +++ b/collects/scribble/run.ss @@ -67,7 +67,7 @@ (when dir (make-directory* dir)) - (let ([renderer (new ((current-render-mixin) render% ) + (let ([renderer (new ((current-render-mixin) render%) [dest-dir dir])]) (let* ([fns (map (lambda (fn) (let-values ([(base name dir?) (split-path fn)]) @@ -82,8 +82,15 @@ [files (reverse (current-info-input-files))]) (if (null? files) info - (loop (send renderer load-info (car files) info) + (loop (let ([s (with-input-from-file (car files) read)]) + (send renderer deserialize-info s info) + info) (cdr files))))]) - (send renderer render docs fns info)) - (when (current-info-output-file) - (send renderer save-info (current-info-output-file) info))))))) + (let ([r-info (send renderer resolve docs fns info)]) + (send renderer render docs fns r-info) + (when (current-info-output-file) + (let ([s (send renderer serialize-info r-info)]) + (with-output-to-file (current-info-output-file) + (lambda () + (write s)) + 'truncate/replace)))))))))) diff --git a/collects/scribble/scheme.ss b/collects/scribble/scheme.ss index d08be8c4..60e3a569 100644 --- a/collects/scribble/scheme.ss +++ b/collects/scribble/scheme.ss @@ -1,9 +1,10 @@ -(module scheme mzscheme +(module scheme (lib "lang.ss" "big") (require "struct.ss" "basic.ss" (lib "class.ss") (lib "for.ss") - (lib "modcollapse.ss" "syntax")) + (lib "main-collects.ss" "setup") + (lib "modresolve.ss" "syntax")) (provide define-code to-element @@ -33,13 +34,7 @@ (define opt-color "schemeopt") (define current-keyword-list - ;; This is temporary, until the MzScheme manual is filled in... - (make-parameter null #;'(require - provide - new send else => and or - define-syntax syntax-rules define-struct - quasiquote unquote unquote-splicing - syntax quasisyntax unsyntax unsyntax-splicing))) + (make-parameter null)) (define current-variable-list (make-parameter null)) (define current-meta-list @@ -51,7 +46,76 @@ (define-struct spaces (pre cnt post)) - (define (typeset c multi-line? prefix1 prefix suffix color?) + (define (literalize-spaces i) + (let ([m (regexp-match-positions #rx" +" i)]) + (if m + (make-spaces (literalize-spaces (substring i 0 (caar m))) + (- (cdar m) (caar m)) + (literalize-spaces (substring i (cdar m)))) + i))) + + (define (typeset-atom c out color? quote-depth) + (let-values ([(s it? sub?) + (let ([c (syntax-e c)]) + (let ([s (format "~s" c)]) + (if (and (symbol? c) + ((string-length s) . > . 1) + (char=? (string-ref s 0) #\_)) + (values (substring s 1) #t #f) + (values s #f #f))))] + [(is-var?) (and (identifier? c) + (memq (syntax-e c) (current-variable-list)))]) + (if (or (element? (syntax-e c)) + (delayed-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 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)) + (literalize-spaces s)) + (cond + [(positive? quote-depth) value-color] + [(let ([v (syntax-e c)]) + (or (number? v) + (string? v) + (bytes? v) + (char? v) + (regexp? v) + (byte-regexp? v) + (boolean? v))) + value-color] + [(identifier? c) + (cond + [is-var? + variable-color] + [(and (identifier? c) + (memq (syntax-e c) (current-keyword-list))) + keyword-color] + [(and (identifier? c) + (memq (syntax-e c) (current-meta-list))) + meta-color] + [it? variable-color] + [else symbol-color])] + [else paren-color]) + (string-length s))))) + + (define (gen-typeset c multi-line? prefix1 prefix suffix color?) (let* ([c (syntax-ize c 0)] [content null] [docs null] @@ -80,6 +144,10 @@ [(and (element? v) (= 1 (length (element-content v)))) (sz-loop (car (element-content v)))] + [(element? v) + (element-width v)] + [(delayed-element? v) + (element-width v)] [(spaces? v) (+ (sz-loop (spaces-pre v)) (spaces-cnt v) @@ -176,13 +244,6 @@ c) (loop (cdr l) (cons (car l) prev))))])))))) - (define (literalize-spaces i) - (let ([m (regexp-match-positions #rx" +" i)]) - (if m - (make-spaces (literalize-spaces (substring i 0 (caar m))) - (- (cdar m) (caar m)) - (literalize-spaces (substring i (cdar m)))) - i))) (define (no-fancy-chars s) (cond [(eq? s 'rsquo) "'"] @@ -359,65 +420,10 @@ (set! src-col (+ orig-col (syntax-span c)))))] [else (advance c init-line!) - (let-values ([(s it? sub?) - (let ([c (syntax-e c)]) - (let ([s (format "~s" c)]) - (if (and (symbol? c) - ((string-length s) . > . 1) - (char=? (string-ref s 0) #\_)) - (values (substring s 1) #t #f) - (values s #f #f))))] - [(is-var?) (and (identifier? c) - (memq (syntax-e c) (current-variable-list)))]) - (if (element? (syntax-e c)) - (out (syntax-e c) #f) - (out (if (and (identifier? c) - color? - (quote-depth . <= . 0) - (not (or it? is-var?))) - (make-delayed-element - (lambda (renderer sec ht) - (let* ([vtag (register-scheme-definition c)] - [stag (register-scheme-form-definition c)] - [vd (hash-table-get ht vtag #f)] - [sd (hash-table-get ht stag #f)]) - (list - (cond - [sd - (make-link-element "schemesyntaxlink" (list s) stag)] - [vd - (make-link-element "schemevaluelink" (list s) vtag)] - [else s])))) - (lambda () s) - (lambda () s)) - (literalize-spaces s)) - (cond - [(positive? quote-depth) value-color] - [(or (number? (syntax-e c)) - (string? (syntax-e c)) - (bytes? (syntax-e c)) - (char? (syntax-e c)) - (regexp? (syntax-e c)) - (byte-regexp? (syntax-e c)) - (boolean? (syntax-e c))) - value-color] - [(identifier? c) - (cond - [is-var? - variable-color] - [(and (identifier? c) - (memq (syntax-e c) (current-keyword-list))) - keyword-color] - [(and (identifier? c) - (memq (syntax-e c) (current-meta-list))) - meta-color] - [it? variable-color] - [else symbol-color])] - [else paren-color]) - (string-length s))) - (set! src-col (+ src-col (or (syntax-span c) 1))) - #; - (hash-table-put! next-col-map src-col dest-col))]))) + (typeset-atom c out color? quote-depth) + (set! src-col (+ src-col (or (syntax-span c) 1))) + #; + (hash-table-put! next-col-map src-col dest-col)]))) (out prefix1 #f) (set! dest-col 0) (hash-table-put! next-col-map init-col dest-col) @@ -436,6 +442,25 @@ (make-table "schemeblock" (map list (reverse docs)))) (make-sized-element #f (reverse content) dest-col)))) + (define (typeset c multi-line? prefix1 prefix suffix color?) + (let* ([c (syntax-ize c 0)] + [s (syntax-e c)]) + (if (or multi-line? + (eq? 'code:blank s) + (pair? s) + (vector? s) + (box? s) + (null? s) + (hash-table? s)) + (gen-typeset c multi-line? prefix1 prefix suffix color?) + (typeset-atom c + (case-lambda + [(elem color) + (make-sized-element (and color? color) (list elem) (or (syntax-span c) 1))] + [(elem color len) + (make-sized-element (and color? color) (list elem) len)]) + color? 0)))) + (define (to-element c) (typeset c #f "" "" "" #t)) @@ -457,15 +482,15 @@ (cond [(syntax? v) (let ([mk `(,#'d->s - (quote-syntax ,v) + (quote-syntax ,(datum->syntax-object v 'defcode)) ,(syntax-case v (uncode) [(uncode e) #'e] [else (stx->loc-s-expr (syntax-e v))]) - (list 'code - ,(syntax-line v) - ,(syntax-column v) - ,(syntax-position v) - ,(syntax-span v)))]) + '(code + ,(syntax-line v) + ,(syntax-column v) + ,(syntax-position v) + ,(syntax-span v)))]) (let ([prop (syntax-property v 'paren-shape)]) (if prop `(,#'stx-prop ,mk 'paren-shape ,prop) @@ -484,27 +509,43 @@ [(_ expr) #`(typeset-code #,(cvt #'expr))] [(_ expr (... ...)) #`(typeset-code #,(cvt #'(code:line expr (... ...))))])))] + [(_ code typeset-code uncode d->s) + #'(define-code code typeset-code uncode d->s syntax-property)] [(_ code typeset-code uncode) #'(define-code code typeset-code uncode datum->syntax-object syntax-property)] [(_ code typeset-code) #'(define-code code typeset-code unsyntax)])) - (define (register-scheme-definition stx) + (define (register-scheme stx [warn-if-no-label? #f]) (unless (identifier? stx) (error 'register-scheme-definition "not an identifier: ~e" (syntax-object->datum stx))) - (format "definition:~a" - (let ([b (identifier-binding stx)]) - (cond - [(not b) (format "top:~a" (syntax-e stx))] - [(eq? b 'lexical) (format "lexical:~a" (syntax-e stx))] - [else (format "module:~a:~a" - (if (module-path-index? (car b)) - (collapse-module-path-index (car b) '(lib "ack.ss" "scribble")) - (car b)) - (cadr b))])))) + (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" + (if (module-path-index? (car b)) + (let ([p (resolve-module-path-index (car b) #f)]) + (path->main-collects-relative p)) + (car b)) + (cadr b))))) - (define (register-scheme-form-definition stx) - (format "form~s" (register-scheme-definition stx))) + (define (register-scheme-definition stx [warn-if-no-label? #f]) + `(def ,(register-scheme stx warn-if-no-label?))) + + (define (register-scheme-form-definition stx [warn-if-no-label? #f]) + `(form ,(register-scheme stx warn-if-no-label?))) (define syntax-ize-hook (make-parameter (lambda (v col) #f))) @@ -551,7 +592,11 @@ (just-context-ctx v)))] [(and (list? v) (pair? v) - (memq (car v) '(quote unquote unquote-splicing))) + (memq (let ([s (car v)]) + (if (just-context? s) + (just-context-val s) + s)) + '(quote unquote unquote-splicing))) (let ([c (syntax-ize (cadr v) (+ col 1))]) (datum->syntax-object #f (list (syntax-ize (car v) col) diff --git a/collects/scribble/scribble.css b/collects/scribble/scribble.css index 843c4272..160ff538 100644 --- a/collects/scribble/scribble.css +++ b/collects/scribble/scribble.css @@ -140,6 +140,10 @@ text-decoration: none; } + .nobreak { + white-space: nowrap; + } + .title { font-size: 200%; font-weight: normal; diff --git a/collects/scribble/struct.ss b/collects/scribble/struct.ss index 5c07eeca..24001b98 100644 --- a/collects/scribble/struct.ss +++ b/collects/scribble/struct.ss @@ -1,8 +1,56 @@ -(module struct mzscheme +(module struct (lib "lang.ss" "big") (require (lib "contract.ss") (lib "serialize.ss")) + ;; ---------------------------------------- + + (define-struct collect-info (ht ext-ht parts tags gen-prefix)) + (define-struct resolve-info (ci delays undef)) + + (define (part-collected-info part ri) + (hash-table-get (collect-info-parts (resolve-info-ci ri)) + part)) + + + (define (collect-put! ci key val) + (hash-table-put! (collect-info-ht ci) + key + val)) + + (define (resolve-get/where part ri key) + (let ([key (tag-key key ri)]) + (let ([v (hash-table-get (if part + (collected-info-info (part-collected-info part ri)) + (collect-info-ht (resolve-info-ci ri))) + key + #f)]) + (cond + [v (values v #f)] + [part (resolve-get/where (collected-info-parent + (part-collected-info part ri)) + ri + key)] + [else + (let ([v (hash-table-get (collect-info-ext-ht (resolve-info-ci ri)) + key + #f)]) + (values v #t))])))) + + (define (resolve-get part ri key) + (let-values ([(v ext?) (resolve-get/where part ri key)]) + v)) + + (provide + (struct collect-info (ht ext-ht parts tags gen-prefix)) + (struct resolve-info (ci delays undef)) + part-collected-info + collect-put! + resolve-get + resolve-get/where) + + ;; ---------------------------------------- + (provide provide-structs) (define-syntax (provide-structs stx) @@ -36,12 +84,12 @@ fields+cts)))))])) (provide tag?) - (define (tag? s) (or (string? s) - (and (pair? s) - (symbol? (car s)) - (pair? (cdr s)) - (string? (cadr s)) - (null? (cddr s))))) + (define (tag? s) (and (pair? s) + (symbol? (car s)) + (pair? (cdr s)) + (or (string? (cadr s)) + (generated-tag? (cadr s))) + (null? (cddr s)))) (provide flow-element?) (define (flow-element? p) @@ -52,21 +100,21 @@ (delayed-flow-element? p))) (provide-structs - [part ([tags (listof tag?)] + [part ([tag-prefix (or/c false/c string?)] + [tags (listof tag?)] [title-content (or/c false/c list?)] - [collected-info (or/c false/c collected-info?)] + [style any/c] [to-collect list?] [flow flow?] [parts (listof part?)])] - [(styled-part part) ([style any/c])] - [(unnumbered-part styled-part) ()] + [(unnumbered-part part) ()] [flow ([paragraphs (listof flow-element?)])] [paragraph ([content list?])] [(styled-paragraph paragraph) ([style any/c])] [table ([style any/c] [flowss (listof (listof (or/c flow? (one-of/c 'cont))))])] [(auxiliary-table table) ()] - [delayed-flow-element ([render (any/c part? any/c . -> . flow-element?)])] + [delayed-flow-element ([resolve (any/c part? resolve-info? . -> . flow-element?)])] [itemization ([flows (listof flow?)])] [blockquote ([style any/c] [paragraphs (listof flow-element?)])] @@ -81,6 +129,7 @@ [plain-seq (listof string?)] [entry-seq list?])] [(aux-element element) ()] + [(hover-element element) ([text string?])] ;; specific renders support other elements, especially strings [collected-info ([number (listof (or/c false/c integer?))] @@ -89,46 +138,32 @@ [target-url ([addr string?])] [image-file ([path path-string?])]) - + ;; ---------------------------------------- ;; Delayed element has special serialization support: - (define-values (struct:delayed-element - make-delayed-element - delayed-element? - delayed-element-ref - delayed-element-set!) - (make-struct-type 'delayed-element #f - 3 1 #f - (list (cons prop:serializable - (make-serialize-info - (lambda (d) - (unless (delayed-element-ref d 3) - (error 'serialize-delayed-element - "cannot serialize a delayed element that was not resolved: ~e" - d)) - (vector (delayed-element-ref d 3))) - #'deserialize-delayed-element - #f - (or (current-load-relative-directory) (current-directory))))))) - (define-syntax delayed-element (list-immutable #'struct:delayed-element - #'make-delayed-element - #'delayed-element? - (list-immutable #'delayed-element-plain - #'delayed-element-sizer - #'delayed-element-render) - (list-immutable #'set-delayed-element-plain! - #'set-delayed-element-sizer! - #'set-delayed-element-render!) - #t)) - (define delayed-element-render (make-struct-field-accessor delayed-element-ref 0)) - (define delayed-element-sizer (make-struct-field-accessor delayed-element-ref 1)) - (define delayed-element-plain (make-struct-field-accessor delayed-element-ref 2)) - (define set-delayed-element-render! (make-struct-field-mutator delayed-element-set! 0)) - (define set-delayed-element-sizer! (make-struct-field-mutator delayed-element-set! 1)) - (define set-delayed-element-plain! (make-struct-field-mutator delayed-element-set! 2)) + (define-struct delayed-element (resolve sizer plain) + #:property + prop:serializable + (make-serialize-info + (lambda (d) + (let ([ri (current-serialize-resolve-info)]) + (unless ri + (error 'serialize-delayed-element + "current-serialize-resolve-info not set")) + (with-handlers ([exn:fail:contract? + (lambda (exn) + (error 'serialize-delayed-element + "serialization failed (wrong resolve info?); ~a" + (exn-message exn)))]) + (vector + (make-element #f (delayed-element-content d ri)))))) + #'deserialize-delayed-element + #f + (or (current-load-relative-directory) (current-directory)))) + (provide/contract - (struct delayed-element ([render (any/c part? any/c . -> . list?)] + (struct delayed-element ([resolve (any/c part? resolve-info? . -> . list?)] [sizer (-> any)] [plain (-> any)]))) @@ -136,12 +171,90 @@ (define deserialize-delayed-element (make-deserialize-info values values)) - (provide force-delayed-element) - (define (force-delayed-element d renderer sec ht) - (or (delayed-element-ref d 3) - (let ([v ((delayed-element-ref d 0) renderer sec ht)]) - (delayed-element-set! d 3 v) - v))) + (provide delayed-element-content) + (define (delayed-element-content e ri) + (hash-table-get (resolve-info-delays ri) e)) + + (provide delayed-flow-element-flow-elements) + (define (delayed-flow-element-flow-elements p ri) + (hash-table-get (resolve-info-delays ri) p)) + + (provide current-serialize-resolve-info) + (define current-serialize-resolve-info (make-parameter #f)) + + ;; ---------------------------------------- + + (define-struct (collect-element element) (collect) + #:property + prop:serializable + (make-serialize-info + (lambda (d) + (vector (collect-element-collect d))) + #'deserialize-collect-element + #f + (or (current-load-relative-directory) (current-directory)))) + + (provide deserialize-collect-element) + (define deserialize-collect-element + (make-deserialize-info values values)) + + (provide/contract + [struct collect-element ([style any/c] + [content list?] + [collect (collect-info? . -> . any)])]) + + ;; ---------------------------------------- + + (define-struct generated-tag () + #:property + prop:serializable + (make-serialize-info + (lambda (g) + (let ([ri (current-serialize-resolve-info)]) + (unless ri + (error 'serialize-generated-tag + "current-serialize-resolve-info not set")) + (let ([t (hash-table-get (collect-info-tags + (resolve-info-ci ri)) + g + #f)]) + (if t + (vector t) + (error 'serialize-generated-tag + "serialization failed (wrong resolve info?)"))))) + #'deserialize-generated-tag + #f + (or (current-load-relative-directory) (current-directory)))) + + (provide + (struct generated-tag ())) + + (provide deserialize-generated-tag) + (define deserialize-generated-tag + (make-deserialize-info values values)) + + (provide generate-tag tag-key) + + (define (generate-tag tg ci) + (if (generated-tag? (cadr tg)) + (let ([t (cadr tg)]) + (list (car tg) + (let ([tags (collect-info-tags ci)]) + (or (hash-table-get tags t #f) + (let ([key (format "gentag:~a~a" + (collect-info-gen-prefix ci) + (hash-table-count tags))]) + (hash-table-put! tags t key) + key))))) + tg)) + + (define (tag-key tg ri) + (if (generated-tag? (cadr tg)) + (list (car tg) + (hash-table-get (collect-info-tags + (resolve-info-ci ri)) + (cadr tg))) + tg)) ;; ---------------------------------------- @@ -151,8 +264,8 @@ (define content->string (case-lambda [(c) (c->s c element->string)] - [(c renderer sec ht) (c->s c (lambda (e) - (element->string e renderer sec ht)))])) + [(c renderer sec ri) (c->s c (lambda (e) + (element->string e renderer sec ri)))])) (define (c->s c do-elem) (apply string-append @@ -171,12 +284,12 @@ [(rsquo) "'"] [(rarr) "->"] [else (format "~s" c)])])] - [(c renderer sec ht) + [(c renderer sec ri) (cond - [(element? c) (content->string (element-content c) renderer sec ht)] + [(element? c) (content->string (element-content c) renderer sec ri)] [(delayed-element? c) - (content->string (force-delayed-element c renderer sec ht) - renderer sec ht)] + (content->string (delayed-element-content c ri) + renderer sec ri)] [else (element->string c)])])) ;; ---------------------------------------- @@ -226,5 +339,14 @@ ;; ---------------------------------------- + (provide part-style?) + + (define (part-style? p s) + (let ([st (part-style p)]) + (or (eq? s st) + (and (list? st) (memq s st))))) + + ;; ---------------------------------------- + ) diff --git a/collects/scribblings/scribble/basic.scrbl b/collects/scribblings/scribble/basic.scrbl index bce5f6fd..aa19fcf1 100644 --- a/collects/scribblings/scribble/basic.scrbl +++ b/collects/scribblings/scribble/basic.scrbl @@ -96,6 +96,11 @@ removed.} @scheme[pre-flow] list is parsed with @scheme[decode-flow]. } +@defproc[(item? [v any/c]) boolean?]{ + +Returns @scheme[#t] if @scheme[v] is an item produced by +@scheme[item], @scheme[#f] otherwise.} + @defform[(include-section module-path)]{ Requires @scheme[module-path] and returns its @scheme[doc] export (without making any imports visible to the enclosing context). Since this form expands to diff --git a/collects/scribblings/scribble/decode.scrbl b/collects/scribblings/scribble/decode.scrbl index 3d3c94b4..0727542d 100644 --- a/collects/scribblings/scribble/decode.scrbl +++ b/collects/scribblings/scribble/decode.scrbl @@ -5,7 +5,7 @@ @title[#:tag "decode"]{Text Decoder} The @file{decode.ss} library helps you write document content in a -natural way---more like plain text, except for @elem["@"] escapes. +natural way---more like plain text, except for @litchar["@"] escapes. Roughly, it processes a stream of strings to produces instances of the @file{struct.ss} datatypes (see @secref["struct"]). @@ -34,24 +34,26 @@ special text conversions: Decodes a document, producing a part. In @scheme[lst], instances of @scheme[splice] are inlined into the list. An instance of @scheme[title-decl] supplies the title for the part. Instances of -@scheme[index-section-decl] (that preceed any sub-part) add index -entries that point to the section. Instances of @scheme[part-start] at -level 0 trigger sub-part parsing. Instances of @scheme[section] -trigger are used as-is as subsections, and instances of -@scheme[paragraph] and other flow-element datatypes are used as-is in -the enclosing flow. +@scheme[part-index-decl] (that precede any sub-part) add index entries +that point to the section. Instances of @scheme[part-collect-decl] add +elements to the part that are used only during the @techlink{collect +pass}. Instances of @scheme[part-start] at level 0 trigger sub-part +parsing. Instances of @scheme[section] trigger are used as-is as +subsections, and instances of @scheme[paragraph] and other +flow-element datatypes are used as-is in the enclosing flow. } @defproc[(decode-part [lst list?] - [tag string?] + [tags (listof string?)] [title (or/c false/c list?)] [depth excat-nonnegative-integer?]) part?]{ -Like @scheme[decode], but given a tag for the section, a title (if -@scheme[#f], then a @scheme[title-decl] instance is used if found), -and a depth for @scheme[part-start]s to trigger sub-part parsing. +Like @scheme[decode], but given a list of tag string for the part, a +title (if @scheme[#f], then a @scheme[title-decl] instance is used if +found), and a depth for @scheme[part-start]s to trigger sub-part +parsing. } @@ -90,28 +92,41 @@ otherwise. } -@defstruct[title-decl ([tag any/c] +@defstruct[title-decl ([tag-prefix (or/c false/c string?)] + [tags (listof string?)] + [style any/c] [content list?])]{ -See @scheme[decode] and @scheme[decode-part]. +See @scheme[decode] and @scheme[decode-part]. The @scheme[tag-prefix] +and @scheme[style] fields are propagated to the resulting +@scheme[part]. } @defstruct[part-start ([depth integer?] - [tag (or/c false/c string?)] + [tag-prefix (or/c false/c string?)] + [tags (listof string?)] + [style any/c] [title list?])]{ -See @scheme[decode] and @scheme[decode-part]. +Like @scheme[title-decl], but for a sub-part. See @scheme[decode] and +@scheme[decode-part]. } @defstruct[part-index-decl ([plain-seq (listof string?)] - [content-seq list?])]{ + [entry-seq list?])]{ See @scheme[decode]. The two fields are as for @scheme[index-element]. } +@defstruct[part-collect-decl ([element element?])]{ + +See @scheme[decode]. + +} + @defstruct[splice ([run list?])]{ See @scheme[decode], @scheme[decode-part], and @scheme[decode-flow]. diff --git a/collects/scribblings/scribble/how-to.scrbl b/collects/scribblings/scribble/how-to.scrbl new file mode 100644 index 00000000..cef9ddad --- /dev/null +++ b/collects/scribblings/scribble/how-to.scrbl @@ -0,0 +1,474 @@ +#reader(lib "docreader.ss" "scribble") +@require[(lib "manual.ss" "scribble") + (lib "bnf.ss" "scribble")] +@require["utils.ss"] + +@title{How to Scribble Documentation} + +@;---------------------------------------- +@section[#:tag "getting-started"]{Getting Started} + +To document a collection or @|PLaneT| package: + +@itemize{ + + @item{Create a file in your collection or planet package with the + file extension @file{.scrbl}. The remainder of these + instructions assume that the file is called @file{manual.scrbl}.} + + @item{Start @file{manual.scrbl} like this: +@verbatim[#< . flow-element?)])]{ - -For the @scheme[render] procedure, the first argument corresponds to -the rendering context, the second to the immediately enclosing -section, and the last argument correspond to global information -(possibly psanning multiple documents). +A @techlink{table} has, roughly, a list of list of flows. A cell in +the table can span multiple columns by using @scheme['cont] instead of +a flow in the following columns (i.e., for all but the first in a set +of cells that contain a single flow). } @defstruct[itemization ([flows (listof flow?)])]{ +A @techlink{itemization} has a list of flows. + } @defstruct[blockquote ([style any/c] - [flows (listof flow-element?)])]{ + [paragraphs (listof flow-element?)])]{ + +A @techlink{blockquote} has a style and a list of flow elements. The +@scheme[style] field is normally a string that corresponds to a CSS +class for HTML output. } +@defstruct[delayed-flow-element ([resolve (any/c part? resolve-info? . -> . flow-element?)])]{ + +The @scheme[resolve] procedure is called during the @techlink{resolve +pass} to obtain a normal flow element. The first argument to +@scheme[resolve] is the renderer. + +} + + @defstruct[element ([style any/c] [content list?])]{ +The @scheme[style] field is normally either + +@itemize{ + + @item{a string, which corresponds to a CSS class for HTML output;} + + @item{one of the symbols that all renderers recognize: @scheme['tt], + @scheme['italic], @scheme['bold], @scheme['sf], + @scheme['subscript], @scheme['superscript], or + @scheme['hspace];} + + @item{an instance of @scheme[target-url] to generate a hyperlink; or} + + @item{an instance of @scheme[image-file] to support an inline image.} + } +The @scheme[content] field is a list of @techlink{elements}. + +} + + @defstruct[(target-element element) ([tag tag?])]{ +Declares the content as a hyperlink target for @scheme[tag]. + } + @defstruct[(toc-target-element target-element) ()]{ +Like @scheme[target-element], the content is also a kind of section +label to be shown in the ``on this page'' table for HTML output. + } -@defstruct[(link-element element) ([tag any/c] - [complain-if-fail? boolean?])]{ + +@defstruct[(link-element element) ([tag any/c])]{ + +Hyperlinks the content to @scheme[tag]. } @@ -227,49 +364,69 @@ section, and the last argument correspond to global information [entry-seq list?])]{ The @scheme[plain-seq] specifies the keys for sorting, where the first -element is the main key, the second is a sub-key, etc. The -@scheme[entry-seq] list must have the same length, and it provides the -form of each key to render in the final document. See also -@scheme[index]. + element is the main key, the second is a sub-key, etc. The + @scheme[entry-seq] list must have the same length, and it provides + the form of each key to render in the final document. See also + @scheme[index]. } + @defstruct[(aux-element element) ()]{ Instances of this structure type are intended for use in titles, where -the auxiliary part of the title can be omitted in hyperlinks. See, for -example, @scheme[secref]. + the auxiliary part of the title can be omitted in hyperlinks. See, + for example, @scheme[secref]. } -@defstruct[delayed-element ([render (any/c part? any/c . -> . list?)] +@defstruct[delayed-element ([resolve (any/c part? resolve-info? . -> . list?)] [sizer (-> any/c)] [plain (-> any/c)])]{ The @scheme[render] procedure's arguments are the same as for -@scheme[delayed-flow-element]. Unlike @scheme[delayed-flow-element], -the result of the @scheme[render] procedure's argument is remembered -on the first call. Furthemore, the element can be marshelled (e.g., -for an index entry or a section-title entry) only if it has been -rendered first. + @scheme[delayed-flow-element]. Unlike @scheme[delayed-flow-element], + the result of the @scheme[render] procedure's argument is remembered + on the first call. The @scheme[sizer] field is a procedure that produces a substitute -element for the delayed element for the purposes of determine the -element's width (see @scheme[element-width]). + element for the delayed element for the purposes of determining the + element's width (see @scheme[element-width]). The @scheme[plain] field is a procedure that produces a substitute for -the element when needed before the ``collect'' phase. + the element when needed before the @techlink{collect pass}. } + +@defstruct[(collect-element element) ([collect (collect-info . -> . any)])]{ + +Like @scheme[element], but the @scheme[collect] procedure is called +during the @techlink{collect pass}. The @scheme[collect] procedure +normally calls @scheme[collect-put!]. + +} + + @defstruct[collected-info ([number (listof (or/c false/c integer?))] [parent (or/c false/c part?)] [info any/c])]{ -Computed for each part by the ``collect'' phase. +Computed for each part by the @techlink{collect pass}. } + +@defstruct[target-url ([addr string?])]{ + +Used as a style for an @scheme[element].} + + +@defstruct[image-file ([path path-string?])]{ + +Used as a style for an @scheme[element].} + + @defproc[(flow-element? [v any/c]) boolean?]{ Returns @scheme[#t] if @scheme[v] is a @scheme[paragraph], @@ -281,13 +438,22 @@ Returns @scheme[#t] if @scheme[v] is a @scheme[paragraph], @defproc[(tag? [v any/c]) boolean?]{ -Returns @scheme[#t] if @scheme[v] is acceptable as a link tag, -@scheme[#f], otherwise. Currently, an acceptable tag is either a -string or a list containing a symbol and a string.} +Returns @scheme[#t] if @scheme[v] is acceptable as a link tag, which +is a list containing a symbol and either a string or a +@scheme[generated-tag] instance.} + + +@defstruct[generated-tag ()]{ + +A placeholder for a tag to be generated during the @scheme{collect + pass}. Use @scheme[tag-key] to convert a tag containing a + @scheme[generated-tag] instance to one containing a string. + +} @defproc*[([(content->string (content list?)) string?] - [(content->string (content list?) (p part?) (info any/c)) string?])]{ + [(content->string (content list?) (p part?) (info resolve-info?)) string?])]{ Converts a list of elements to a single string (essentially rendering the content as ``plain text''). @@ -299,7 +465,65 @@ element (if it has not been forced already).} @defproc*[([(element->string (element any/c)) string?] - [(element->string (element any/c) (p part?) (info any/c)) string?])]{ + [(element->string (element any/c) (p part?) (info resolve-info?)) string?])]{ Like @scheme[content->string], but for a single element. } + +@defproc[(element-width (element any/c)) nonnegative-exact-integer?]{ + +Returns the width in characters of the given element.} + + +@defproc[(flow-element-width (e flow-element?)) nonnegative-exact-integer?]{ + +Returns the width in characters of the given flow element.} + +@defstruct[collect-info ([ht any/c] [ext-ht any/c] [parts any/c] [tags any/c] [gen-prefix any/c])]{ + +Encapsulates information accumulated (or being accumulated) from the +@techlink{collect pass}. The fields are exposed, but not currently +intended for external use. + +} + +@defstruct[resolve-info ([ci any/c] [delays any/c] [undef any/c])]{ + +Encapsulates information accumulated (or being accumulated) from the +@techlink{resolve pass}. The fields are exposed, but not currently +intended for external use. + +} + +@defproc[(collect-put! [ci collect-info?] [key any/c] [val any/c]) + void?]{ + +Registers information in @scheme[ci]. This procedure should be called +only during the @techlink{collect pass}. + +} + +@defproc[(resolve-get [ri resolve-info?] [key any/c]) + void?]{ + +Extract information during the @techlink{resolve pass} or +@techlink{render pass} from @scheme[ri], where the information was +previously registered during the @techlink{collect pass}. See also +@secref["passes"]. + +} + +@defproc[(part-collected-info [p part?] + [ri resolve-info?]) + collected-info?]{ + +Returns the information collected for @scheme[p] as recorded within +@scheme[ri]. + +} + +@defproc[(tag-key [t tag?] [ri resolve-info?]) tag?]{ + +Converts a @scheme[generated-tag] value with @scheme[t] to a string. + +} diff --git a/collects/scribblings/scribble/style.scrbl b/collects/scribblings/scribble/style.scrbl index d8f535b8..23eb243e 100644 --- a/collects/scribblings/scribble/style.scrbl +++ b/collects/scribblings/scribble/style.scrbl @@ -2,12 +2,10 @@ @require[(lib "manual.ss" "scribble")] @require["utils.ss"] -@title[#:tag "reference-style"]{PLT Reference Style Guide} - -@italic{Notes toward an eventual guide chapter...} +@title[#:tag "reference-style"]{Style Guide} In the descriptive body of @scheme[defform], @scheme[defproc], etc., -do not start with ``This...'' Instead, start with a sentence whose +do not start with ``This ...'' Instead, start with a sentence whose implicit subject is the form or value being described. Thus, the description will often start with ``Produces.'' Refer to arguments by name. @@ -20,24 +18,6 @@ expression position within a syntactic form. Use @schemeidfont{body} for a form (definition or expression) in an internal-definition position. -Break up HTML documents into multiple pages by using the @scheme['toc] -section style in combination with -@scheme[local-table-of-contents]. The @scheme[local-table-of-contents] -should go after a short introduction, if any. In some cases, a longer -introduction is better placed after the -@scheme[local-table-of-contents] call, especially if the contents are -short. - -Favor hyperlinks installed by @scheme[scheme] instead of explicit -section links produced by @scheme[secref]. In particular, there's -rarely a need to have both links (e.g., ``see @scheme[scheme] in -@secref["scribble:manual:code"]''). - -Link tags are resolved relative to surrounding sections, but if you -think anyone will ever refer to a link targer, try to pick a tag that -will be globally unique. For example, all of the section tags in the -PLT Scheme reference start with @litchar["mz:"]. - Pay attention to the difference between identifiers and meta-variables when using @scheme[scheme], especially outside of @scheme[defproc] or @scheme[defform]. Prefix a meta-variable with @litchar{_}; for diff --git a/collects/scribblings/scribble/utils.ss b/collects/scribblings/scribble/utils.ss index 0be48cab..942aa05c 100644 --- a/collects/scribblings/scribble/utils.ss +++ b/collects/scribblings/scribble/utils.ss @@ -6,6 +6,23 @@ (prefix scribble: (lib "reader.ss" "scribble")) (lib "string.ss")) + (define-syntax bounce-for-label + (syntax-rules () + [(_ mod) (begin + (require-for-label mod) + (provide-for-label (all-from mod)))] + [(_ mod ...) (begin (bounce-for-label mod) ...)])) + + (bounce-for-label (lib "lang.ss" "big") + (lib "struct.ss" "scribble") + (lib "base-render.ss" "scribble") + (lib "decode.ss" "scribble") + (lib "basic.ss" "scribble") + (lib "manual.ss" "scribble") + (lib "scheme.ss" "scribble") + (lib "eval.ss" "scribble") + (lib "bnf.ss" "scribble")) + (provide scribble-examples litchar/lines) (define (litchar/lines . strs)