From 13025bff7a53c82b0367ece5932fc92b3150f50c Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 12 Jan 2008 18:32:30 +0000 Subject: [PATCH] add master index svn: r8310 --- collects/scribble/basic.ss | 141 ++++++++++++------ collects/scribble/html-render.ss | 63 ++++---- collects/scribble/latex-render.ss | 17 ++- collects/scribble/manual.ss | 7 +- collects/scribble/scribble.css | 1 - collects/scribble/struct.ss | 4 +- collects/scribblings/guide/guide.scrbl | 6 +- collects/scribblings/master-index/info.ss | 4 + .../master-index/master-index.scrbl | 8 + collects/scribblings/scribble/struct.scrbl | 6 +- collects/scribblings/start/info.ss | 2 +- collects/scribblings/start/manuals.ss | 72 +++++---- collects/scribblings/start/start.scrbl | 13 ++ .../scribblings/user-master-index/info.ss | 4 + .../user-master-index/master-index.scrbl | 8 + collects/scribblings/user-start/info.ss | 2 +- .../scribblings/user-start/user-start.scrbl | 6 + collects/setup/pack.ss | 77 +++++----- collects/setup/scribble.ss | 99 +++++++----- collects/setup/xref.ss | 18 ++- 20 files changed, 358 insertions(+), 200 deletions(-) create mode 100644 collects/scribblings/master-index/info.ss create mode 100644 collects/scribblings/master-index/master-index.scrbl create mode 100644 collects/scribblings/user-master-index/info.ss create mode 100644 collects/scribblings/user-master-index/master-index.scrbl diff --git a/collects/scribble/basic.ss b/collects/scribble/basic.ss index ef6fcbbb15..6e1f69dde2 100644 --- a/collects/scribble/basic.ss +++ b/collects/scribble/basic.ss @@ -157,7 +157,7 @@ ;; ---------------------------------------- - (provide section-index index index* as-index index-section) + (provide section-index index index* as-index index-section index-flow-elements) (define (section-index . elems) (make-part-index-decl (map element->string elems) elems)) @@ -192,58 +192,107 @@ key content))) - (define (index-section #:tag [tag #f]) + (define (index-section #:title [title "Index"] #:tag [tag #f]) (make-unnumbered-part #f `((part ,(or tag "doc-index"))) - '("Index") + (list title) 'index null - (make-flow (list (make-delayed-flow-element - (lambda (renderer sec ri) - (let ([l null]) - (hash-table-for-each - (collected-info-info - (part-collected-info - (collected-info-parent - (part-collected-info sec ri)) - ri)) - (lambda (k v) - (when (and (pair? k) - (eq? 'index-entry (car k))) - (set! l (cons (cons (cadr k) v) l))))) - (let ([l (sort - l - (lambda (a b) - (let loop ([a (cadr a)][b (cadr b)]) - (cond - [(null? a) #t] - [(null? b) #f] - [(string-ci=? (car a) (car b)) - (loop (cdr a) (cdr b))] - [else - (string-cilist "ABCDEFGHIJKLMNOPQRSTUVWXYZ")]) + (cond + [(null? alpha) null] + [(null? i) (add-letter (car alpha) + (loop i (cdr alpha)))] + [else (let* ([strs (cadr (car i))] + [letter (if (or (null? strs) + (string=? "" (car strs))) + #f + (string-ref (car strs) 0))]) + (cond + [(not letter) (loop (cdr i) alpha)] + [(char-ci>? letter (car alpha)) + (add-letter (car alpha) + (loop i (cdr alpha)))] + [(char-ci=? letter (car alpha)) + (hash-table-put! alpha-starts (car i) letter) + (list* (make-element (make-target-url + (format "#alpha:~a" letter) + #f) + (list (string (car alpha)))) + " " + (loop (cdr i) (cdr alpha)))] + [else (loop (cdr i) alpha)]))]))))))) + (list (make-flow (list (make-paragraph (list 'nbsp))))) + (map (lambda (i) + (list (make-flow + (list + (make-paragraph + (list + (let ([e (make-link-element + "indexlink" + (commas (caddr i)) + (car i))]) + (let ([letter (hash-table-get alpha-starts i #f)]) + (if letter + (make-element (make-url-anchor (format "alpha:~a" letter)) + (list e)) + e))))))))) + l))))))))) + ;; ---------------------------------------- (provide table-of-contents diff --git a/collects/scribble/html-render.ss b/collects/scribble/html-render.ss index 0455d9b4b2..3f26a91211 100644 --- a/collects/scribble/html-render.ss +++ b/collects/scribble/html-render.ss @@ -182,7 +182,7 @@ (part-parts (caar l))) (cdr l))))] [else (cons (car l) (loop (cdr l)))])))]) - (if (null? toc-content) + (if (and #f (null? toc-content)) null `((div ((class "tocview")) (div ((class "tocviewtitle")) @@ -253,6 +253,8 @@ (cond [(toc-target-element? a) (cons a (loop (cdr c)))] + [(toc-element? a) + (cons a (loop (cdr c)))] [(element? a) (append (loop (element-content a)) (loop (cdr c)))] @@ -284,25 +286,27 @@ ((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" (anchor-name (tag-key (car (part-tags p)) ri))) - (format "#~a" (anchor-name (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))))))) + `(tr + (td + ,@(if (part? p) + `((span ((class "tocsublinknumber")) + ,@(format-number (collected-info-number + (part-collected-info p ri)) + '((tt nbsp))))) + '("")) + ,@(if (toc-element? p) + (render-content (toc-element-toc-content p) d ri) + (parameterize ([current-no-links #t] + [extra-breaking? #t]) + `((a ((href ,(if (part? p) + (format "#~a" (anchor-name (tag-key (car (part-tags p)) ri))) + (format "#~a" (anchor-name (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) @@ -478,7 +482,14 @@ (if (current-no-links) (super render-element e part ri) (parameterize ([current-no-links #t]) - `((a ((href ,(target-url-addr style))) ,@(super render-element e part ri)))))] + `((a ((href ,(target-url-addr style)) + ,@(if (string? (target-url-style style)) + `((class ,(target-url-style style))) + null)) + ,@(super render-element e part ri)))))] + [(url-anchor? style) + `((a ((name ,(url-anchor-name style))) + ,@(super render-element e part ri)))] [(image-file? style) `((img ((src ,(install-file (image-file-path style))))))] [else (super render-element e part ri)]))) @@ -737,7 +748,7 @@ (list (make-element (if parent - (make-target-url "index.html") + (make-target-url "index.html" #f) "nonavigation") contents-content)) (if index @@ -761,7 +772,8 @@ (if parent (make-target-url (if prev (derive-filename prev) - "index.html")) + "index.html") + #f) "nonavigation") prev-content) sep-element @@ -770,13 +782,14 @@ (make-target-url (if (toc-part? parent) (derive-filename parent) - "index.html")) + "index.html") + #f) "nonavigation") up-content) sep-element (make-element (if next - (make-target-url (derive-filename next)) + (make-target-url (derive-filename next) #f) "nonavigation") next-content)) d diff --git a/collects/scribble/latex-render.ss b/collects/scribble/latex-render.ss index af25af4245..435fed775b 100644 --- a/collects/scribble/latex-render.ss +++ b/collects/scribble/latex-render.ss @@ -244,9 +244,12 @@ [opt (cond [(equal? tableform "longtable") "[l]"] [(equal? tableform "tabular") "[t]"] - [else ""])]) - (unless (or (null? (table-flowss t)) - (null? (car (table-flowss t)))) + [else ""])] + [flowss (if index? + (cddr (table-flowss t)) + (table-flowss t))]) + (unless (or (null? flowss) + (null? (car flowss))) (parameterize ([current-table-mode (if inline? (current-table-mode) (list tableform t))] @@ -273,14 +276,14 @@ [(center) "c"] [(right) "r"] [else "l"]))) - (car (table-flowss t)) + (car flowss) (cdr (or (and (list? (table-style t)) (assoc 'alignment (or (table-style t) null))) - (cons #f (map (lambda (x) #f) (car (table-flowss t)))))))))]) - (let loop ([flowss (table-flowss t)] + (cons #f (map (lambda (x) #f) (car flowss))))))))]) + (let loop ([flowss flowss] [row-styles (cdr (or (and (list? (table-style t)) (assoc 'row-styles (table-style t))) - (cons #f (map (lambda (x) #f) (table-flowss t)))))]) + (cons #f (map (lambda (x) #f) flowss))))]) (let ([flows (car flowss)] [row-style (car row-styles)]) (let loop ([flows flows]) diff --git a/collects/scribble/manual.ss b/collects/scribble/manual.ss index c47fc9b72c..0b2194c22c 100644 --- a/collects/scribble/manual.ss +++ b/collects/scribble/manual.ss @@ -306,8 +306,11 @@ (define (procedure . str) (make-element "schemeresult" (append (list "#")))) - (define (link url . str) - (make-element (make-target-url url) (decode-content str))) + (define (link url #:underline? [underline? #t] . str) + (make-element (make-target-url url (if underline? + #f + "plainlink")) + (decode-content str))) (define (schemeerror . str) (make-element "schemeerror" (decode-content str))) diff --git a/collects/scribble/scribble.css b/collects/scribble/scribble.css index 998a24032e..d3f8e46604 100644 --- a/collects/scribble/scribble.css +++ b/collects/scribble/scribble.css @@ -136,7 +136,6 @@ font-weight: bold; } .tocsub { - margin-top: 1em; text-align: left; background-color: #DCF5F5; } diff --git a/collects/scribble/struct.ss b/collects/scribble/struct.ss index f4be3e8451..c18c6fb0cc 100644 --- a/collects/scribble/struct.ss +++ b/collects/scribble/struct.ss @@ -158,6 +158,7 @@ ;; content = list of elements [element ([style any/c] [content list?])] + [(toc-element element) ([toc-content list?])] [(target-element element) ([tag tag?])] [(toc-target-element target-element) ()] [(page-target-element target-element) ()] @@ -174,7 +175,8 @@ [parent (or/c false/c part?)] [info any/c])] - [target-url ([addr string?])] + [target-url ([addr string?][style any/c])] + [url-anchor ([name string?])] [image-file ([path path-string?])]) ;; ---------------------------------------- diff --git a/collects/scribblings/guide/guide.scrbl b/collects/scribblings/guide/guide.scrbl index f5b6dcc2dd..edeb9727e6 100644 --- a/collects/scribblings/guide/guide.scrbl +++ b/collects/scribblings/guide/guide.scrbl @@ -121,8 +121,10 @@ programs. describes the PLT Scheme web server, which supports servlets implemented in Scheme. -Run @exec{plt-help} to find documentation for many other libraries -that are distributed with PLT Scheme or installed on your system. +@link["../index.html"]{PLT Scheme Documentation} lists documentation +for many other installed libraries. Run @exec{plt-help} to find +documentation for libraries that are installed on your system and +specific to your user account. @link["http://planet.plt-scheme.org/"]{@|PLaneT|} offers even more downloadable packages contributed by PLT Scheme users. diff --git a/collects/scribblings/master-index/info.ss b/collects/scribblings/master-index/info.ss new file mode 100644 index 0000000000..53c4f04b7f --- /dev/null +++ b/collects/scribblings/master-index/info.ss @@ -0,0 +1,4 @@ +(module info setup/infotab + (define name "Scribblings: Master Index") + (define scribblings '(("master-index.scrbl" (depends-all-main no-depend-on)))) + (define doc-categories '(omit))) diff --git a/collects/scribblings/master-index/master-index.scrbl b/collects/scribblings/master-index/master-index.scrbl new file mode 100644 index 0000000000..856b10cea7 --- /dev/null +++ b/collects/scribblings/master-index/master-index.scrbl @@ -0,0 +1,8 @@ +#lang scribble/doc +@(require scribble/basic + scribble/decode) + +@title{Master Index} + +@(make-splice (index-flow-elements)) + diff --git a/collects/scribblings/scribble/struct.scrbl b/collects/scribblings/scribble/struct.scrbl index 50c6168d1a..0fad019d69 100644 --- a/collects/scribblings/scribble/struct.scrbl +++ b/collects/scribblings/scribble/struct.scrbl @@ -462,9 +462,11 @@ Computed for each part by the @techlink{collect pass}. } -@defstruct[target-url ([addr string?])]{ +@defstruct[target-url ([addr string?] + [style any/c])]{ -Used as a style for an @scheme[element].} +Used as a style for an @scheme[element]. The @scheme[style] at this +layer is a style for the hyperlink.} @defstruct[image-file ([path path-string?])]{ diff --git a/collects/scribblings/start/info.ss b/collects/scribblings/start/info.ss index 128168045b..6839a78450 100644 --- a/collects/scribblings/start/info.ss +++ b/collects/scribblings/start/info.ss @@ -1,4 +1,4 @@ (module info setup/infotab (define name "Scribblings: Start") - (define scribblings '(("start.scrbl" (main-doc-root always-run)))) + (define scribblings '(("start.scrbl" (main-doc-root always-run depends-all-main no-depend-on)))) (define doc-categories '(omit))) diff --git a/collects/scribblings/start/manuals.ss b/collects/scribblings/start/manuals.ss index 46304529ff..fccaa4852d 100644 --- a/collects/scribblings/start/manuals.ss +++ b/collects/scribblings/start/manuals.ss @@ -42,38 +42,46 @@ (if (or all? (main-collects? dir)) (let ([s (i 'scribblings)]) - (map (lambda (d cat) - (let ([new-cat (if (or (symbol? cat) - (and (list? cat) - (= 2 (length cat)) - (symbol? (car cat)) - (real? (cadr cat)))) - cat - 'unknown)]) - (list - ;; Category - (let ([the-cat (if (list? new-cat) - (car new-cat) - new-cat)]) - (case the-cat - [(getting-started language tool library foreign other omit) - the-cat] - [else - (fprintf (current-error-port) - "WARNING: base category: ~e from: ~e" - cat - dir)])) - ;; Priority - (if (list? new-cat) - (cadr new-cat) - 0) - ;; Path - (if (pair? d) - (build-path dir (car d)) - (build-path dir "???"))))) - s - (i 'doc-categories (lambda () - (map (lambda (i) 'library) s))))) + (apply + append + (map (lambda (d cat) + (if (and (not all?) + (pair? (cdr d)) + (or (memq 'user-doc (cadr d)) + (memq 'user-doc-root (cadr d)))) + null + (let ([new-cat (if (or (symbol? cat) + (and (list? cat) + (= 2 (length cat)) + (symbol? (car cat)) + (real? (cadr cat)))) + cat + 'unknown)]) + (list + (list + ;; Category + (let ([the-cat (if (list? new-cat) + (car new-cat) + new-cat)]) + (case the-cat + [(getting-started language tool library foreign other omit) + the-cat] + [else + (fprintf (current-error-port) + "WARNING: base category: ~e from: ~e" + cat + dir)])) + ;; Priority + (if (list? new-cat) + (cadr new-cat) + 0) + ;; Path + (if (pair? d) + (build-path dir (car d)) + (build-path dir "???"))))))) + s + (i 'doc-categories (lambda () + (map (lambda (i) 'library) s)))))) null)) infos dirs))] diff --git a/collects/scribblings/start/start.scrbl b/collects/scribblings/start/start.scrbl index a9b647d051..cc5896ffa8 100644 --- a/collects/scribblings/start/start.scrbl +++ b/collects/scribblings/start/start.scrbl @@ -1,8 +1,21 @@ #lang scribble/doc @(require scribble/manual + scribble/struct "manuals.ss") @title{PLT Scheme Documentation} +@margin-note{This is an installation-specific listing. Running + @exec{plt-help} may open a different + page with local and user-specific documentation, + including documentation for installed @|PLaneT| packages.} + @(build-contents #f) +@(make-toc-element + #f + null + (list @link["master-index/index.html" + #:underline? #f + (make-element "tocsubseclink" + (list "Master Index"))])) diff --git a/collects/scribblings/user-master-index/info.ss b/collects/scribblings/user-master-index/info.ss new file mode 100644 index 0000000000..d88ba19ed4 --- /dev/null +++ b/collects/scribblings/user-master-index/info.ss @@ -0,0 +1,4 @@ +(module info setup/infotab + (define name "Scribblings: User Master Index") + (define scribblings '(("master-index.scrbl" (user-doc depends-all no-depend-on)))) + (define doc-categories '(omit))) diff --git a/collects/scribblings/user-master-index/master-index.scrbl b/collects/scribblings/user-master-index/master-index.scrbl new file mode 100644 index 0000000000..959fb5820f --- /dev/null +++ b/collects/scribblings/user-master-index/master-index.scrbl @@ -0,0 +1,8 @@ +#lang scribble/doc +@(require scribble/basic + scribble/decode) + +@title{Master Index (user)} + +@(make-splice (index-flow-elements)) + diff --git a/collects/scribblings/user-start/info.ss b/collects/scribblings/user-start/info.ss index 24d5fcf0b3..2831560bee 100644 --- a/collects/scribblings/user-start/info.ss +++ b/collects/scribblings/user-start/info.ss @@ -1,4 +1,4 @@ (module info setup/infotab (define name "Scribblings: User Start") - (define scribblings '(("user-start.scrbl" (user-doc-root always-run)))) + (define scribblings '(("user-start.scrbl" (user-doc-root depends-all always-run no-depend-on)))) (define doc-categories '(omit))) diff --git a/collects/scribblings/user-start/user-start.scrbl b/collects/scribblings/user-start/user-start.scrbl index 1cb41d2b01..e860fbefc2 100644 --- a/collects/scribblings/user-start/user-start.scrbl +++ b/collects/scribblings/user-start/user-start.scrbl @@ -1,5 +1,6 @@ #lang scribble/doc @(require scribble/manual + scribble/struct "../start/manuals.ss") @title{PLT Scheme Documentation (user)} @@ -10,3 +11,8 @@ @other-manual['(lib "scribblings/start/start.scrbl")].} @(build-contents #t) + +@(make-toc-element + #f + null + (list @link["master-index/index.html" #:underline? #f]{master index})) diff --git a/collects/setup/pack.ss b/collects/setup/pack.ss index f0ce0be57f..aa712c5a8e 100644 --- a/collects/setup/pack.ss +++ b/collects/setup/pack.ss @@ -1,13 +1,11 @@ ;; Utilities for creating a .plt package -(module pack mzscheme - (require (lib "deflate.ss") - (lib "base64.ss" "net") - (lib "process.ss") - (lib "list.ss") - (lib "port.ss") - (lib "file.ss") - (lib "kw.ss") - (lib "getinfo.ss" "setup")) +(module pack scheme/base + (require file/gzip + net/base64 + scheme/system + scheme/port + scheme/file + setup/getinfo) (provide pack pack-plt @@ -21,15 +19,15 @@ "requires a true value for `~a' argument") arg1-name v arg2-name)) - (define/kw (pack dest name paths collections - #:optional [file-filter std-filter] - [encode? #t] - [file-mode 'file] - [unpack-unit #f] - [plt-relative? #t] - [requires null] - [conflicts null] - [at-plt-home? #f]) + (define (pack dest name paths collections + [file-filter std-filter] + [encode? #t] + [file-mode 'file] + [unpack-unit #f] + [plt-relative? #t] + [requires null] + [conflicts null] + [at-plt-home? #f]) (pack-plt dest name paths #:collections collections #:file-filter file-filter @@ -40,23 +38,23 @@ #:requires null #:conflicts null #:at-plt-home? at-plt-home?)) - - (define/kw (pack-plt dest name paths - #:key [collections null] - [file-filter std-filter] - [encode? #t] - [file-mode 'file] - [unpack-unit #f] - [plt-relative? #t] - [requires null] - [conflicts null] - [at-plt-home? #f] - [test-plt-dirs #f]) + + (define (pack-plt dest name paths + #:collections [collections null] + #:file-filter [file-filter std-filter] + #:encode? [encode? #t] + #:file-mode [file-mode 'file] + #:unpack-unit [unpack-unit #f] + #:plt-relative? [plt-relative? #t] + #:requires [requires null] + #:conflicts [conflicts null] + #:at-plt-home? [at-plt-home? #f] + #:test-plt-dirs [test-plt-dirs #f]) (when (and at-plt-home? (not plt-relative?)) (x-arg-needs-true-arg 'pack-plt 'at-plt-home? at-plt-home? 'plt-relative?)) (when (and test-plt-dirs (not at-plt-home?)) (x-arg-needs-true-arg 'pack-plt 'test-plt-dirs test-plt-dirs 'at-plt-home?)) - (let*-values ([(file) (open-output-file dest 'truncate/replace)] + (let*-values ([(file) (open-output-file dest #:exists 'truncate/replace)] [(fileout thd) (if encode? (let-values ([(b64-out b64-in) (make-pipe 4096)] @@ -185,21 +183,20 @@ (regexp-match #rx#"~$|^#.*#$|^[.]#" name) (regexp-match #rx#"[.]plt$" name)))))) - (define/kw (pack-collections - output name collections replace? extra-setup-collections - #:optional [file-filter std-filter] at-plt-home?) + (define (pack-collections output name collections replace? extra-setup-collections + [file-filter std-filter] [at-plt-home? #f]) (pack-collections-plt output name collections #:replace? replace? #:extra-setup-collections extra-setup-collections #:file-filter file-filter #:at-plt-home? at-plt-home?)) - (define/kw (pack-collections-plt output name collections - #:key [replace? #f] - [extra-setup-collections null] - [file-filter std-filter] - [at-plt-home? #f] - [test-plt-collects? #t]) + (define (pack-collections-plt output name collections + #:replace? [replace? #f] + #:extra-setup-collections [extra-setup-collections null] + #:file-filter [file-filter std-filter] + #:at-plt-home? [at-plt-home? #f] + #:test-plt-collects? [test-plt-collects? #t]) (let-values ([(dir source-files requires conflicts name) (let ([dirs (map (lambda (cp) (apply collection-path cp)) collections)]) diff --git a/collects/setup/scribble.ss b/collects/setup/scribble.ss index 4717527f61..165e276ee0 100644 --- a/collects/setup/scribble.ss +++ b/collects/setup/scribble.ss @@ -23,40 +23,32 @@ vers rendered?) #:mutable) -(define (user-start-doc? doc) - (memq 'user-doc-root (doc-flags doc))) +(define (user-doc? doc) + (or (memq 'user-doc-root (doc-flags doc)) + (memq 'user-doc (doc-flags doc)))) (define (filter-user-start docs) - ;; If we've built it before... + ;; If we've built user-specific before... (if (file-exists? (build-path (find-user-doc-dir) "index.html")) ;; Keep building: docs ;; Otherwise, see if we need it: (let ([cnt-not-main (apply + (map (lambda (doc) - (if (doc-under-main? doc) + (if (or (doc-under-main? doc) + (memq 'no-depend-on (doc-flags doc))) 0 1)) - docs))] - [start? (ormap (lambda (doc) - (memq 'main-doc-root (doc-flags doc))) - docs)] - [user-start? (ormap user-start-doc? docs)]) - (let ([any-not-main? (positive? - (- cnt-not-main - (if start? 1 0) - (if user-start? 1 0)))]) + docs))]) + (let ([any-not-main? (positive? cnt-not-main)]) (cond [any-not-main? - ;; Need it: + ;; Need user-specific: docs] - [user-start? - ;; Don't need it, so drop it: - (filter (lambda (doc) (not (user-start-doc? doc))) - docs)] - [else - ;; Wasn't planning to build it, anyway: - docs]))))) + [else + ;; Don't need them, so drop them: + (filter (lambda (doc) (not (user-doc? doc))) + docs)]))))) (define (setup-scribblings only-dirs ; limits doc builds latex-dest ; if not #f, generate Latex output @@ -77,7 +69,11 @@ (member i '(main-doc main-doc-root user-doc-root + user-doc multi-page + depends-all + depends-all-main + no-depend-on always-run))) (cadr v)) (or (null? (cddr v)) @@ -88,6 +84,7 @@ (let* ([flags (if (pair? (cdr d)) (cadr d) null)] [under-main? (and (not (memq 'main-doc-root flags)) (not (memq 'user-doc-root flags)) + (not (memq 'user-doc flags)) (or (memq 'main-doc flags) (pair? (path->main-collects-relative dir))))]) (make-doc dir @@ -103,6 +100,8 @@ (find-doc-dir)] [(memq 'user-doc-root flags) (find-user-doc-dir)] + [(memq 'user-doc flags) + (build-path (find-user-doc-dir) name)] [else (if under-main? (build-path (find-doc-dir) name) @@ -119,7 +118,15 @@ infos dirs)] [docs (filter-user-start (apply append docs))]) (when (ormap (can-build? only-dirs) docs) - (let ([infos (filter values (map (get-doc-info only-dirs latex-dest auto-start-doc?) docs))]) + (let* ([auto-main? (and auto-start-doc? + (ormap (can-build? only-dirs) + (filter doc-under-main? docs)))] + [auto-user? (and auto-start-doc? + (ormap (can-build? only-dirs) + (filter (lambda (doc) (not (doc-under-main? doc))) + docs)))] + [infos (filter values (map (get-doc-info only-dirs latex-dest auto-main? auto-user?) + docs))]) (let loop ([first? #t] [iter 0]) (let ([ht (make-hash-table 'equal)]) ;; Collect definitions @@ -152,15 +159,33 @@ (info-deps info))) (for ([d (info-deps info)]) (let ([i (if (info? d) - d - (hash-table-get src->info d #f))]) + d + (hash-table-get src->info d #f))]) (if i - (hash-table-put! deps i #t) - (begin - (set! added? #t) - (when (verbose) - (printf " [Removed Dependency: ~a]\n" - (doc-src-file (info-doc info)))))))) + (hash-table-put! deps i #t) + (unless (or (memq 'depends-all (doc-flags (info-doc info))) + (and (doc-under-main? (info-doc i)) + (memq 'depends-all-main (doc-flags (info-doc info))))) + (set! added? #t) + (when (verbose) + (printf " [Removed Dependency: ~a]\n" + (doc-src-file (info-doc info)))))))) + (let ([all-main? (memq 'depends-all-main (doc-flags (info-doc info)))]) + (when (or (memq 'depends-all (doc-flags (info-doc info))) + all-main?) + ;; Add all: + (when (verbose) + (printf " [Adding all~a as dependencies: ~a]\n" + (if all-main? " main" "") + (doc-src-file (info-doc info)))) + (for ([i infos]) + (unless (eq? i info) + (when (not (hash-table-get deps i #f)) + (when (and (or (not all-main?) + (doc-under-main? (info-doc i))) + (not (memq 'no-depend-on (doc-flags (info-doc i))))) + (set! added? #t) + (hash-table-put! deps i #t))))))) (let ([not-found (lambda (k) (unless one? @@ -189,6 +214,7 @@ (printf " [Added Dependency: ~a]\n" (doc-src-file (info-doc info)))) (set-info-deps! info (hash-table-map deps (lambda (k v) k))) + (set-info-need-in-write?! info #t) (set-info-need-run?! info #t))))) ;; If a dependency changed, then we need a re-run: (for ([i infos] @@ -269,7 +295,7 @@ (part-parts v) (and (versioned-part? v) (versioned-part-version v)))))) -(define ((get-doc-info only-dirs latex-dest auto-start-doc?) doc) +(define ((get-doc-info only-dirs latex-dest auto-main? auto-user?) doc) (let* ([info-out-file (build-path (or latex-dest (doc-dest-dir doc)) "out.sxref")] [info-in-file (build-path (or latex-dest (doc-dest-dir doc)) "in.sxref")] [out-file (build-path (doc-dest-dir doc) "index.html")] @@ -300,7 +326,12 @@ (or (not can-run?) (my-time . >= . (max aux-time (file-or-directory-modify-seconds - src-zo #f (lambda () +inf.0))))))]) + src-zo #f (lambda () +inf.0))))))] + [can-run? (or can-run? + (and auto-main? + (memq 'depends-all-main (doc-flags doc))) + (and auto-user? + (memq 'depends-all (doc-flags doc))))]) (printf " [~a ~a]\n" (if up-to-date? "Using" (if can-run? "Running" "Skipping")) (doc-src-file doc)) @@ -310,7 +341,7 @@ (fprintf (current-error-port) "~a\n" (exn-message exn)) (delete-file info-out-file) (delete-file info-in-file) - ((get-doc-info only-dirs latex-dest auto-start-doc?) doc))]) + ((get-doc-info only-dirs latex-dest auto-main? auto-user?) doc))]) (let* ([v-in (with-input-from-file info-in-file read)] [v-out (with-input-from-file info-out-file read)]) (unless (and (equal? (car v-in) (list vers (doc-flags doc))) @@ -324,7 +355,7 @@ (map rel->path (list-ref v-in 2)) ; deps, in case we don't need to build... can-run? my-time info-out-time - (and (or can-run? auto-start-doc?) + (and can-run? (memq 'always-run (doc-flags doc))) #f #f vers diff --git a/collects/setup/xref.ss b/collects/setup/xref.ss index 1720d0bffb..49dee4f1d7 100644 --- a/collects/setup/xref.ss +++ b/collects/setup/xref.ss @@ -18,12 +18,18 @@ (let-values ([(base name dir?) (split-path (car d))]) (path-replace-suffix name #"")))]) (build-path - (if (memq 'main-doc-root flags) - (find-doc-dir) - (if (or (memq 'main-doc flags) - (pair? (path->main-collects-relative dir))) - (build-path (find-doc-dir) name) - (build-path dir "compiled" "doc" name))) + (cond + [(memq 'main-doc-root flags) + (find-doc-dir)] + [(memq 'user-doc-root flags) + (find-user-doc-dir)] + [(memq 'user-doc flags) + (build-path (find-user-doc-dir) name)] + [(or (memq 'main-doc flags) + (pair? (path->main-collects-relative dir))) + (build-path (find-doc-dir) name)] + [else + (build-path dir "compiled" "doc" name)]) "out.sxref")) #f)) ((get-info/full dir) 'scribblings)))