suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

add master index

Browse Source 
svn: r8310
This commit is contained in:
Matthew Flatt 2008-01-12 18:32:30 +00:00
parent 2c21778b0a
commit 13025bff7a
20 changed files with 358 additions and 200 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

141
collects/scribble/basic.ss
View File

@ -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) (define (section-index . elems)
(make-part-index-decl (map element->string elems) elems)) (make-part-index-decl (map element->string elems) elems))
@ -192,58 +192,107 @@
key key
content))) content)))
(define (index-section #:tag [tag #f]) (define (index-section #:title [title "Index"] #:tag [tag #f])
(make-unnumbered-part (make-unnumbered-part
#f #f
`((part ,(or tag "doc-index"))) `((part ,(or tag "doc-index")))
'("Index") (list title)
'index 'index
null null
(make-flow (list (make-delayed-flow-element (make-flow (index-flow-elements))
(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-ci<? (car a) (car b))]))))]
[commas (lambda (l)
(if (or (null? l)
(null? (cdr l)))
l
(cdr (apply append (map (lambda (i)
(list ", " i))
l)))))])
(make-table
'index
(map (lambda (i)
(list (make-flow
(list
(make-paragraph
(list
(make-link-element
"indexlink"
(commas (caddr i))
(car i))))))))
l))))))))
null)) null))
(define (index-flow-elements)
(list (make-delayed-flow-element
(lambda (renderer sec ri)
(let ([l null])
(hash-table-for-each
(let ([parent (collected-info-parent
(part-collected-info sec ri))])
(if parent
(collected-info-info
(part-collected-info
parent
ri))
(collect-info-ext-ht (resolve-info-ci 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-ci<? (car a) (car b))]))))]
[commas (lambda (l)
(if (or (null? l)
(null? (cdr l)))
l
(cdr (apply append (map (lambda (i)
(list ", " i))
l)))))]
[alpha-starts (make-hash-table)])
(make-table
'index
(list*
(list
(make-flow
(list
(make-paragraph
(let ([add-letter
(lambda (letter l)
(list* (make-element "nonavigation"
(list (string letter)))
" "
l))])
(let loop ([i l]
[alpha (string->list "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 (provide table-of-contents

63
collects/scribble/html-render.ss
View File

@ -182,7 +182,7 @@
(part-parts (caar l))) (part-parts (caar l)))
(cdr l))))] (cdr l))))]
[else (cons (car l) (loop (cdr l)))])))]) [else (cons (car l) (loop (cdr l)))])))])
(if (null? toc-content) (if (and #f (null? toc-content))
null null
`((div ((class "tocview")) `((div ((class "tocview"))
(div ((class "tocviewtitle")) (div ((class "tocviewtitle"))
@ -253,6 +253,8 @@
(cond (cond
[(toc-target-element? a) [(toc-target-element? a)
(cons a (loop (cdr c)))] (cons a (loop (cdr c)))]
[(toc-element? a)
(cons a (loop (cdr c)))]
[(element? a) [(element? a)
(append (loop (element-content a)) (append (loop (element-content a))
(loop (cdr c)))] (loop (cdr c)))]
@ -284,25 +286,27 @@
((class "tocsublist") ((class "tocsublist")
(cellspacing "0")) (cellspacing "0"))
,@(map (lambda (p) ,@(map (lambda (p)
(parameterize ([current-no-links #t] `(tr
[extra-breaking? #t]) (td
`(tr ,@(if (part? p)
(td `((span ((class "tocsublinknumber"))
,@(if (part? p) ,@(format-number (collected-info-number
`((span ((class "tocsublinknumber")) (part-collected-info p ri))
,@(format-number (collected-info-number '((tt nbsp)))))
(part-collected-info p ri)) '(""))
'((tt nbsp))))) ,@(if (toc-element? p)
'("")) (render-content (toc-element-toc-content p) d ri)
(a ((href ,(if (part? p) (parameterize ([current-no-links #t]
(format "#~a" (anchor-name (tag-key (car (part-tags p)) ri))) [extra-breaking? #t])
(format "#~a" (anchor-name (tag-key (target-element-tag p) ri))))) `((a ((href ,(if (part? p)
(class ,(if (part? p) (format "#~a" (anchor-name (tag-key (car (part-tags p)) ri)))
"tocsubseclink" (format "#~a" (anchor-name (tag-key (target-element-tag p) ri)))))
"tocsublink"))) (class ,(if (part? p)
,@(if (part? p) "tocsubseclink"
(render-content (or (part-title-content p) '("???")) d ri) "tocsublink")))
(render-content (element-content p) d ri))))))) ,@(if (part? p)
(render-content (or (part-title-content p) '("???")) d ri)
(render-content (element-content p) d ri)))))))))
ps)))))))) ps))))))))
(define/public (render-one-part d ri fn number) (define/public (render-one-part d ri fn number)
@ -478,7 +482,14 @@
(if (current-no-links) (if (current-no-links)
(super render-element e part ri) (super render-element e part ri)
(parameterize ([current-no-links #t]) (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))))))] [(image-file? style) `((img ((src ,(install-file (image-file-path style))))))]
[else (super render-element e part ri)]))) [else (super render-element e part ri)])))
@ -737,7 +748,7 @@
(list (list
(make-element (make-element
(if parent (if parent
(make-target-url "index.html") (make-target-url "index.html" #f)
"nonavigation") "nonavigation")
contents-content)) contents-content))
(if index (if index
@ -761,7 +772,8 @@
(if parent (if parent
(make-target-url (if prev (make-target-url (if prev
(derive-filename prev) (derive-filename prev)
"index.html")) "index.html")
#f)
"nonavigation") "nonavigation")
prev-content) prev-content)
sep-element sep-element
@ -770,13 +782,14 @@
(make-target-url (make-target-url
(if (toc-part? parent) (if (toc-part? parent)
(derive-filename parent) (derive-filename parent)
"index.html")) "index.html")
#f)
"nonavigation") "nonavigation")
up-content) up-content)
sep-element sep-element
(make-element (make-element
(if next (if next
(make-target-url (derive-filename next)) (make-target-url (derive-filename next) #f)
"nonavigation") "nonavigation")
next-content)) next-content))
d d

17
collects/scribble/latex-render.ss
View File

@ -244,9 +244,12 @@
[opt (cond [opt (cond
[(equal? tableform "longtable") "[l]"] [(equal? tableform "longtable") "[l]"]
[(equal? tableform "tabular") "[t]"] [(equal? tableform "tabular") "[t]"]
[else ""])]) [else ""])]
(unless (or (null? (table-flowss t)) [flowss (if index?
(null? (car (table-flowss t)))) (cddr (table-flowss t))
(table-flowss t))])
(unless (or (null? flowss)
(null? (car flowss)))
(parameterize ([current-table-mode (if inline? (parameterize ([current-table-mode (if inline?
(current-table-mode) (current-table-mode)
(list tableform t))] (list tableform t))]
@ -273,14 +276,14 @@
[(center) "c"] [(center) "c"]
[(right) "r"] [(right) "r"]
[else "l"]))) [else "l"])))
(car (table-flowss t)) (car flowss)
(cdr (or (and (list? (table-style t)) (cdr (or (and (list? (table-style t))
(assoc 'alignment (or (table-style t) null))) (assoc 'alignment (or (table-style t) null)))
(cons #f (map (lambda (x) #f) (car (table-flowss t)))))))))]) (cons #f (map (lambda (x) #f) (car flowss))))))))])
(let loop ([flowss (table-flowss t)] (let loop ([flowss flowss]
[row-styles (cdr (or (and (list? (table-style t)) [row-styles (cdr (or (and (list? (table-style t))
(assoc 'row-styles (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)] (let ([flows (car flowss)]
[row-style (car row-styles)]) [row-style (car row-styles)])
(let loop ([flows flows]) (let loop ([flows flows])

7
collects/scribble/manual.ss
View File

@ -306,8 +306,11 @@
(define (procedure . str) (define (procedure . str)
(make-element "schemeresult" (append (list "#<procedure:") (decode-content str) (list ">")))) (make-element "schemeresult" (append (list "#<procedure:") (decode-content str) (list ">"))))
(define (link url . str) (define (link url #:underline? [underline? #t] . str)
(make-element (make-target-url url) (decode-content str))) (make-element (make-target-url url (if underline?
#f
"plainlink"))
(decode-content str)))
(define (schemeerror . str) (define (schemeerror . str)
(make-element "schemeerror" (decode-content str))) (make-element "schemeerror" (decode-content str)))

1
collects/scribble/scribble.css
View File

@ -136,7 +136,6 @@ font-weight: bold;
} }
.tocsub { .tocsub {
margin-top: 1em;
text-align: left; text-align: left;
background-color: #DCF5F5; background-color: #DCF5F5;
} }

4
collects/scribble/struct.ss
View File

@ -158,6 +158,7 @@
;; content = list of elements ;; content = list of elements
[element ([style any/c] [element ([style any/c]
[content list?])] [content list?])]
[(toc-element element) ([toc-content list?])]
[(target-element element) ([tag tag?])] [(target-element element) ([tag tag?])]
[(toc-target-element target-element) ()] [(toc-target-element target-element) ()]
[(page-target-element target-element) ()] [(page-target-element target-element) ()]
@ -174,7 +175,8 @@
[parent (or/c false/c part?)] [parent (or/c false/c part?)]
[info any/c])] [info any/c])]
[target-url ([addr string?])] [target-url ([addr string?][style any/c])]
[url-anchor ([name string?])]
[image-file ([path path-string?])]) [image-file ([path path-string?])])
;; ---------------------------------------- ;; ----------------------------------------

6
collects/scribblings/guide/guide.scrbl
View File

@ -121,8 +121,10 @@ programs.
describes the PLT Scheme web server, which supports servlets describes the PLT Scheme web server, which supports servlets
implemented in Scheme. implemented in Scheme.
Run @exec{plt-help} to find documentation for many other libraries @link["../index.html"]{PLT Scheme Documentation} lists documentation
that are distributed with PLT Scheme or installed on your system. 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 @link["http://planet.plt-scheme.org/"]{@|PLaneT|} offers even more
downloadable packages contributed by PLT Scheme users. downloadable packages contributed by PLT Scheme users.

4
collects/scribblings/master-index/info.ss Normal file
View File

@ -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)))

8
collects/scribblings/master-index/master-index.scrbl Normal file
View File

@ -0,0 +1,8 @@
#lang scribble/doc
@(require scribble/basic
scribble/decode)
@title{Master Index}
@(make-splice (index-flow-elements))

6
collects/scribblings/scribble/struct.scrbl
View File

@ -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?])]{ @defstruct[image-file ([path path-string?])]{

2
collects/scribblings/start/info.ss
View File

@ -1,4 +1,4 @@
(module info setup/infotab (module info setup/infotab
(define name "Scribblings: Start") (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))) (define doc-categories '(omit)))

72
collects/scribblings/start/manuals.ss
View File

@ -42,38 +42,46 @@
(if (or all? (if (or all?
(main-collects? dir)) (main-collects? dir))
(let ([s (i 'scribblings)]) (let ([s (i 'scribblings)])
(map (lambda (d cat) (apply
(let ([new-cat (if (or (symbol? cat) append
(and (list? cat) (map (lambda (d cat)
(= 2 (length cat)) (if (and (not all?)
(symbol? (car cat)) (pair? (cdr d))
(real? (cadr cat)))) (or (memq 'user-doc (cadr d))
cat (memq 'user-doc-root (cadr d))))
'unknown)]) null
(list (let ([new-cat (if (or (symbol? cat)
;; Category (and (list? cat)
(let ([the-cat (if (list? new-cat) (= 2 (length cat))
(car new-cat) (symbol? (car cat))
new-cat)]) (real? (cadr cat))))
(case the-cat cat
[(getting-started language tool library foreign other omit) 'unknown)])
the-cat] (list
[else (list
(fprintf (current-error-port) ;; Category
"WARNING: base category: ~e from: ~e" (let ([the-cat (if (list? new-cat)
cat (car new-cat)
dir)])) new-cat)])
;; Priority (case the-cat
(if (list? new-cat) [(getting-started language tool library foreign other omit)
(cadr new-cat) the-cat]
0) [else
;; Path (fprintf (current-error-port)
(if (pair? d) "WARNING: base category: ~e from: ~e"
(build-path dir (car d)) cat
(build-path dir "???"))))) dir)]))
s ;; Priority
(i 'doc-categories (lambda () (if (list? new-cat)
(map (lambda (i) 'library) s))))) (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)) null))
infos infos
dirs))] dirs))]

13
collects/scribblings/start/start.scrbl
View File

@ -1,8 +1,21 @@
#lang scribble/doc #lang scribble/doc
@(require scribble/manual @(require scribble/manual
scribble/struct
"manuals.ss") "manuals.ss")
@title{PLT Scheme Documentation} @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) @(build-contents #f)
@(make-toc-element
#f
null
(list @link["master-index/index.html"
#:underline? #f
(make-element "tocsubseclink"
(list "Master Index"))]))

4
collects/scribblings/user-master-index/info.ss Normal file
View File

@ -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)))

8
collects/scribblings/user-master-index/master-index.scrbl Normal file
View File

@ -0,0 +1,8 @@
#lang scribble/doc
@(require scribble/basic
scribble/decode)
@title{Master Index (user)}
@(make-splice (index-flow-elements))

2
collects/scribblings/user-start/info.ss
View File

@ -1,4 +1,4 @@
(module info setup/infotab (module info setup/infotab
(define name "Scribblings: User Start") (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))) (define doc-categories '(omit)))

6
collects/scribblings/user-start/user-start.scrbl
View File

@ -1,5 +1,6 @@
#lang scribble/doc #lang scribble/doc
@(require scribble/manual @(require scribble/manual
scribble/struct
"../start/manuals.ss") "../start/manuals.ss")
@title{PLT Scheme Documentation (user)} @title{PLT Scheme Documentation (user)}
@ -10,3 +11,8 @@
@other-manual['(lib "scribblings/start/start.scrbl")].} @other-manual['(lib "scribblings/start/start.scrbl")].}
@(build-contents #t) @(build-contents #t)
@(make-toc-element
#f
null
(list @link["master-index/index.html" #:underline? #f]{master index}))

75
collects/setup/pack.ss
View File

@ -1,13 +1,11 @@
;; Utilities for creating a .plt package ;; Utilities for creating a .plt package
(module pack mzscheme (module pack scheme/base
(require (lib "deflate.ss") (require file/gzip
(lib "base64.ss" "net") net/base64
(lib "process.ss") scheme/system
(lib "list.ss") scheme/port
(lib "port.ss") scheme/file
(lib "file.ss") setup/getinfo)
(lib "kw.ss")
(lib "getinfo.ss" "setup"))
(provide pack (provide pack
pack-plt pack-plt
@ -21,15 +19,15 @@
"requires a true value for `~a' argument") "requires a true value for `~a' argument")
arg1-name v arg2-name)) arg1-name v arg2-name))
(define/kw (pack dest name paths collections (define (pack dest name paths collections
#:optional [file-filter std-filter] [file-filter std-filter]
[encode? #t] [encode? #t]
[file-mode 'file] [file-mode 'file]
[unpack-unit #f] [unpack-unit #f]
[plt-relative? #t] [plt-relative? #t]
[requires null] [requires null]
[conflicts null] [conflicts null]
[at-plt-home? #f]) [at-plt-home? #f])
(pack-plt dest name paths (pack-plt dest name paths
#:collections collections #:collections collections
#:file-filter file-filter #:file-filter file-filter
@ -41,22 +39,22 @@
#:conflicts null #:conflicts null
#:at-plt-home? at-plt-home?)) #:at-plt-home? at-plt-home?))
(define/kw (pack-plt dest name paths (define (pack-plt dest name paths
#:key [collections null] #:collections [collections null]
[file-filter std-filter] #:file-filter [file-filter std-filter]
[encode? #t] #:encode? [encode? #t]
[file-mode 'file] #:file-mode [file-mode 'file]
[unpack-unit #f] #:unpack-unit [unpack-unit #f]
[plt-relative? #t] #:plt-relative? [plt-relative? #t]
[requires null] #:requires [requires null]
[conflicts null] #:conflicts [conflicts null]
[at-plt-home? #f] #:at-plt-home? [at-plt-home? #f]
[test-plt-dirs #f]) #:test-plt-dirs [test-plt-dirs #f])
(when (and at-plt-home? (not plt-relative?)) (when (and at-plt-home? (not plt-relative?))
(x-arg-needs-true-arg 'pack-plt 'at-plt-home? at-plt-home? '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?)) (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?)) (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) [(fileout thd)
(if encode? (if encode?
(let-values ([(b64-out b64-in) (make-pipe 4096)] (let-values ([(b64-out b64-in) (make-pipe 4096)]
@ -185,21 +183,20 @@
(regexp-match #rx#"~$|^#.*#$|^[.]#" name) (regexp-match #rx#"~$|^#.*#$|^[.]#" name)
(regexp-match #rx#"[.]plt$" name)))))) (regexp-match #rx#"[.]plt$" name))))))
(define/kw (pack-collections (define (pack-collections output name collections replace? extra-setup-collections
output name collections replace? extra-setup-collections [file-filter std-filter] [at-plt-home? #f])
#:optional [file-filter std-filter] at-plt-home?)
(pack-collections-plt output name collections (pack-collections-plt output name collections
#:replace? replace? #:replace? replace?
#:extra-setup-collections extra-setup-collections #:extra-setup-collections extra-setup-collections
#:file-filter file-filter #:file-filter file-filter
#:at-plt-home? at-plt-home?)) #:at-plt-home? at-plt-home?))
(define/kw (pack-collections-plt output name collections (define (pack-collections-plt output name collections
#:key [replace? #f] #:replace? [replace? #f]
[extra-setup-collections null] #:extra-setup-collections [extra-setup-collections null]
[file-filter std-filter] #:file-filter [file-filter std-filter]
[at-plt-home? #f] #:at-plt-home? [at-plt-home? #f]
[test-plt-collects? #t]) #:test-plt-collects? [test-plt-collects? #t])
(let-values (let-values
([(dir source-files requires conflicts name) ([(dir source-files requires conflicts name)
(let ([dirs (map (lambda (cp) (apply collection-path cp)) collections)]) (let ([dirs (map (lambda (cp) (apply collection-path cp)) collections)])

97
collects/setup/scribble.ss
View File

@ -23,40 +23,32 @@
vers rendered?) vers rendered?)
#:mutable) #:mutable)
(define (user-start-doc? doc) (define (user-doc? doc)
(memq 'user-doc-root (doc-flags doc))) (or (memq 'user-doc-root (doc-flags doc))
(memq 'user-doc (doc-flags doc))))
(define (filter-user-start docs) (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")) (if (file-exists? (build-path (find-user-doc-dir) "index.html"))
;; Keep building: ;; Keep building:
docs docs
;; Otherwise, see if we need it: ;; Otherwise, see if we need it:
(let ([cnt-not-main (apply + (let ([cnt-not-main (apply +
(map (lambda (doc) (map (lambda (doc)
(if (doc-under-main? doc) (if (or (doc-under-main? doc)
(memq 'no-depend-on (doc-flags doc)))
0 0
1)) 1))
docs))] docs))])
[start? (ormap (lambda (doc) (let ([any-not-main? (positive? cnt-not-main)])
(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)))])
(cond (cond
[any-not-main? [any-not-main?
;; Need it: ;; Need user-specific:
docs] docs]
[user-start?
;; Don't need it, so drop it:
(filter (lambda (doc) (not (user-start-doc? doc)))
docs)]
[else [else
;; Wasn't planning to build it, anyway: ;; Don't need them, so drop them:
docs]))))) (filter (lambda (doc) (not (user-doc? doc)))
docs)])))))
(define (setup-scribblings only-dirs ; limits doc builds (define (setup-scribblings only-dirs ; limits doc builds
latex-dest ; if not #f, generate Latex output latex-dest ; if not #f, generate Latex output
@ -77,7 +69,11 @@
(member i '(main-doc (member i '(main-doc
main-doc-root main-doc-root
user-doc-root user-doc-root
user-doc
multi-page multi-page
depends-all
depends-all-main
no-depend-on
always-run))) always-run)))
(cadr v)) (cadr v))
(or (null? (cddr v)) (or (null? (cddr v))
@ -88,6 +84,7 @@
(let* ([flags (if (pair? (cdr d)) (cadr d) null)] (let* ([flags (if (pair? (cdr d)) (cadr d) null)]
[under-main? (and (not (memq 'main-doc-root flags)) [under-main? (and (not (memq 'main-doc-root flags))
(not (memq 'user-doc-root flags)) (not (memq 'user-doc-root flags))
(not (memq 'user-doc flags))
(or (memq 'main-doc flags) (or (memq 'main-doc flags)
(pair? (path->main-collects-relative dir))))]) (pair? (path->main-collects-relative dir))))])
(make-doc dir (make-doc dir
@ -103,6 +100,8 @@
(find-doc-dir)] (find-doc-dir)]
[(memq 'user-doc-root flags) [(memq 'user-doc-root flags)
(find-user-doc-dir)] (find-user-doc-dir)]
[(memq 'user-doc flags)
(build-path (find-user-doc-dir) name)]
[else [else
(if under-main? (if under-main?
(build-path (find-doc-dir) name) (build-path (find-doc-dir) name)
@ -119,7 +118,15 @@
infos dirs)] infos dirs)]
[docs (filter-user-start (apply append docs))]) [docs (filter-user-start (apply append docs))])
(when (ormap (can-build? only-dirs) 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 loop ([first? #t] [iter 0])
(let ([ht (make-hash-table 'equal)]) (let ([ht (make-hash-table 'equal)])
;; Collect definitions ;; Collect definitions
@ -152,15 +159,33 @@
(info-deps info))) (info-deps info)))
(for ([d (info-deps info)]) (for ([d (info-deps info)])
(let ([i (if (info? d) (let ([i (if (info? d)
d d
(hash-table-get src->info d #f))]) (hash-table-get src->info d #f))])
(if i (if i
(hash-table-put! deps i #t) (hash-table-put! deps i #t)
(begin (unless (or (memq 'depends-all (doc-flags (info-doc info)))
(set! added? #t) (and (doc-under-main? (info-doc i))
(when (verbose) (memq 'depends-all-main (doc-flags (info-doc info)))))
(printf " [Removed Dependency: ~a]\n" (set! added? #t)
(doc-src-file (info-doc info)))))))) (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 (let ([not-found
(lambda (k) (lambda (k)
(unless one? (unless one?
@ -189,6 +214,7 @@
(printf " [Added Dependency: ~a]\n" (printf " [Added Dependency: ~a]\n"
(doc-src-file (info-doc info)))) (doc-src-file (info-doc info))))
(set-info-deps! info (hash-table-map deps (lambda (k v) k))) (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))))) (set-info-need-run?! info #t)))))
;; If a dependency changed, then we need a re-run: ;; If a dependency changed, then we need a re-run:
(for ([i infos] (for ([i infos]
@ -269,7 +295,7 @@
(part-parts v) (part-parts v)
(and (versioned-part? v) (versioned-part-version 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")] (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")] [info-in-file (build-path (or latex-dest (doc-dest-dir doc)) "in.sxref")]
[out-file (build-path (doc-dest-dir doc) "index.html")] [out-file (build-path (doc-dest-dir doc) "index.html")]
@ -300,7 +326,12 @@
(or (not can-run?) (or (not can-run?)
(my-time . >= . (max aux-time (my-time . >= . (max aux-time
(file-or-directory-modify-seconds (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" (printf " [~a ~a]\n"
(if up-to-date? "Using" (if can-run? "Running" "Skipping")) (if up-to-date? "Using" (if can-run? "Running" "Skipping"))
(doc-src-file doc)) (doc-src-file doc))
@ -310,7 +341,7 @@
(fprintf (current-error-port) "~a\n" (exn-message exn)) (fprintf (current-error-port) "~a\n" (exn-message exn))
(delete-file info-out-file) (delete-file info-out-file)
(delete-file info-in-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)] (let* ([v-in (with-input-from-file info-in-file read)]
[v-out (with-input-from-file info-out-file read)]) [v-out (with-input-from-file info-out-file read)])
(unless (and (equal? (car v-in) (list vers (doc-flags doc))) (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... (map rel->path (list-ref v-in 2)) ; deps, in case we don't need to build...
can-run? can-run?
my-time info-out-time my-time info-out-time
(and (or can-run? auto-start-doc?) (and can-run?
(memq 'always-run (doc-flags doc))) (memq 'always-run (doc-flags doc)))
#f #f #f #f
vers vers

18
collects/setup/xref.ss
View File

@ -18,12 +18,18 @@
(let-values ([(base name dir?) (split-path (car d))]) (let-values ([(base name dir?) (split-path (car d))])
(path-replace-suffix name #"")))]) (path-replace-suffix name #"")))])
(build-path (build-path
(if (memq 'main-doc-root flags) (cond
(find-doc-dir) [(memq 'main-doc-root flags)
(if (or (memq 'main-doc flags) (find-doc-dir)]
(pair? (path->main-collects-relative dir))) [(memq 'user-doc-root flags)
(build-path (find-doc-dir) name) (find-user-doc-dir)]
(build-path dir "compiled" "doc" name))) [(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")) "out.sxref"))
#f)) #f))
((get-info/full dir) 'scribblings))) ((get-info/full dir) 'scribblings)))