add master index
svn: r8310
This commit is contained in:
Matthew Flatt
parent
2c21778b0a
commit
13025bff7a
|
|
@ -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-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))))))))
|
||||
(make-flow (index-flow-elements))
|
||||
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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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])
|
||||
|
|
|
|||
|
|
@ -306,8 +306,11 @@
|
|||
(define (procedure . str)
|
||||
(make-element "schemeresult" (append (list "#<procedure:") (decode-content str) (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)))
|
||||
|
|
|
|||
|
|
@ -136,7 +136,6 @@ font-weight: bold;
|
|||
}
|
||||
|
||||
.tocsub {
|
||||
margin-top: 1em;
|
||||
text-align: left;
|
||||
background-color: #DCF5F5;
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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?])])
|
||||
|
||||
;; ----------------------------------------
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
|
|
|
|||
4
collects/scribblings/master-index/info.ss
Normal file
4
collects/scribblings/master-index/info.ss
Normal 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
8
collects/scribblings/master-index/master-index.scrbl
Normal file
|
|
@ -0,0 +1,8 @@
|
|||
#lang scribble/doc
|
||||
@(require scribble/basic
|
||||
scribble/decode)
|
||||
|
||||
@title{Master Index}
|
||||
|
||||
@(make-splice (index-flow-elements))
|
||||
|
||||
|
|
@ -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?])]{
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
|
|
|
|||
|
|
@ -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))]
|
||||
|
|
|
|||
|
|
@ -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"))]))
|
||||
|
|
|
|||
4
collects/scribblings/user-master-index/info.ss
Normal file
4
collects/scribblings/user-master-index/info.ss
Normal 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)))
|
||||
|
|
@ -0,0 +1,8 @@
|
|||
#lang scribble/doc
|
||||
@(require scribble/basic
|
||||
scribble/decode)
|
||||
|
||||
@title{Master Index (user)}
|
||||
|
||||
@(make-splice (index-flow-elements))
|
||||
|
||||
|
|
@ -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)))
|
||||
|
|
|
|||
|
|
@ -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}))
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -41,22 +39,22 @@
|
|||
#: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)])
|
||||
|
|
|
|||
|
|
@ -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])))))
|
||||
;; 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
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user