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

change path->main-collects-relative, and change output directory of start document

Browse Source 
svn: r8301
This commit is contained in:
Matthew Flatt 2008-01-11 19:54:38 +00:00
parent ce04c9457b
commit 05434ec54d
9 changed files with 621 additions and 646 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
collects/mzlib/cm.ss
View File

@ -90,7 +90,7 @@
(lambda (op) (lambda (op)
(write (cons (version) (write (cons (version)
(append (map path->main-collects-relative deps) (append (map path->main-collects-relative deps)
(map (lambda (x) (path->main-collects-relative (cons 'ext x))) (map (lambda (x) (cons 'ext (path->main-collects-relative x)))
external-deps))) external-deps)))
op) op)
(newline op))))) (newline op)))))
@ -264,7 +264,12 @@
(when (> t path-zo-time) (when (> t path-zo-time)
(trace-printf "newer: ~a (~a > ~a)..." d t path-zo-time)) (trace-printf "newer: ~a (~a > ~a)..." d t path-zo-time))
(> t path-zo-time))) (> t path-zo-time)))
(map main-collects-relative->path (cdr deps))) (map (lambda (p)
(if (and (pair? p)
(eq? 'ext (car p)))
(cons 'ext (main-collects-relative->path (cdr p)))
(main-collects-relative->path p)))
(cdr deps)))
(compile-zo mode path)))))) (compile-zo mode path))))))
(let ((stamp (get-compiled-time mode path #t))) (let ((stamp (get-compiled-time mode path #t)))
(hash-table-put! up-to-date path stamp) (hash-table-put! up-to-date path stamp)

6
collects/scheme/private/contract-helpers.ss
View File

@ -78,7 +78,11 @@
[r (and bs (path->main-collects-relative bs))]) [r (and bs (path->main-collects-relative bs))])
(and bs (and bs
(bytes->string/locale (if (and (pair? r) (eq? 'collects (car r))) (bytes->string/locale (if (and (pair? r) (eq? 'collects (car r)))
(bytes-append #"<collects>/" (cdr r)) (apply bytes-append
#"<collects>"
(map (lambda (s)
(bytes-append #"/" s))
(cdr r)))
bs))))) bs)))))
;; build-src-loc-string : syntax -> (union #f string) ;; build-src-loc-string : syntax -> (union #f string)

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

@ -76,6 +76,8 @@
format-number format-number
quiet-table-of-contents) quiet-table-of-contents)
(init-field [css-path #f])
(define/override (get-suffix) #".html") (define/override (get-suffix) #".html")
;; ---------------------------------------- ;; ----------------------------------------
@ -133,6 +135,9 @@
(define/private (reveal-subparts? p) (define/private (reveal-subparts? p)
(part-style? p 'reveal)) (part-style? p 'reveal))
(define/public (toc-wrap table)
null)
(define/public (render-toc-view d ri) (define/public (render-toc-view d ri)
(let-values ([(top mine) (let-values ([(top mine)
(let loop ([d d][mine d]) (let loop ([d d][mine d])
@ -185,10 +190,11 @@
(class "tocviewlink")) (class "tocviewlink"))
,@(render-content (or (part-title-content top) '("???")) d ri))) ,@(render-content (or (part-title-content top) '("???")) d ri)))
(div nbsp) (div nbsp)
(table ,@(toc-wrap
((class "tocviewlist") `(table
(cellspacing "0")) ((class "tocviewlist")
,@toc-content))))) (cellspacing "0"))
,@toc-content))))))
,@(render-onthispage-contents d ri top) ,@(render-onthispage-contents d ri top)
,@(apply append ,@(apply append
(map (lambda (t) (map (lambda (t)
@ -311,18 +317,31 @@
null)) null))
(link ((rel "stylesheet") (link ((rel "stylesheet")
(type "text/css") (type "text/css")
(href "scribble.css") (href ,(or css-path "scribble.css"))
(title "default")))) (title "default"))))
(body ,@(render-toc-view d ri) (body ,@(render-toc-view d ri)
(div ((class "maincolumn")) (div ((class "maincolumn"))
(div ((class "main")) ,@(render-part d ri)))))]) (div ((class "main"))
(install-file scribble-css) ,@(render-version d ri)
,@(render-part d ri)))))])
(unless css-path
(install-file scribble-css))
(printf "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.0 Transitional//EN\" \"http://www.w3.org/TR/html4/loose.dtd\">\n") (printf "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.0 Transitional//EN\" \"http://www.w3.org/TR/html4/loose.dtd\">\n")
(xml:write-xml/content (xml:xexpr->xml xpr))))) (xml:write-xml/content (xml:xexpr->xml xpr)))))
(define/override (render-one d ri fn) (define/override (render-one d ri fn)
(render-one-part d ri fn null)) (render-one-part d ri fn null))
(define/public (render-version d ri)
`((div ([class "versionbox"])
,@(render-content
(list
(make-element "version"
(list "Version: "
(current-version))))
d
ri))))
(define/override (render-part d ri) (define/override (render-part d ri)
(let ([number (collected-info-number (part-collected-info d ri))]) (let ([number (collected-info-number (part-collected-info d ri))])
`(,@(if (and (not (part-title-content d)) `(,@(if (and (not (part-title-content d))
@ -646,6 +665,9 @@
`((div ((class "tocsubtitle")) `((div ((class "tocsubtitle"))
"On this page:"))) "On this page:")))
(define/override (toc-wrap p)
(list p))
(define contents-content '("contents")) (define contents-content '("contents"))
(define index-content '("index")) (define index-content '("index"))
(define prev-content '(larr " prev")) (define prev-content '(larr " prev"))
@ -654,7 +676,11 @@
(define no-next-content next-content) (define no-next-content next-content)
(define sep-element (make-element #f '(nbsp nbsp))) (define sep-element (make-element #f '(nbsp nbsp)))
(inherit render-table) (inherit render-table
render-paragraph)
(define/override (render-version r i)
null)
(define/private (find-siblings d ri) (define/private (find-siblings d ri)
(let ([parent (collected-info-parent (part-collected-info d ri))]) (let ([parent (collected-info-parent (part-collected-info d ri))])
@ -705,68 +731,56 @@
(let ([d (car (last-pair subs))]) (let ([d (car (last-pair subs))])
(and (part-style? d 'index) (and (part-style? d 'index)
d)))))))]) d)))))))])
`(,@(render-table (make-table `((div ([class "navleft"])
'at-left ,@(render-content
(list (append
(cons (list
(make-flow (make-element
(list (if parent
(make-paragraph (make-target-url "index.html")
(list "nonavigation")
(make-element contents-content))
(if parent (if index
(make-target-url "index.html") (list
"nonavigation") 'nbsp
contents-content))))) (if (eq? d index)
(if index (make-element
(list "nonavigation"
(make-flow index-content)
(list (make-link-element
(make-paragraph #f
(list index-content
'nbsp (car (part-tags index)))))
(if (eq? d index) null))
(make-element d
"nonavigation" ri))
index-content) (div ([class "navright"])
(make-link-element ,@(render-content
#f (list
index-content (make-element
(car (part-tags index))))))))) (if parent
null)))) (make-target-url (if prev
d ri) (derive-filename prev)
,@(render-table (make-table "index.html"))
'at-right "nonavigation")
(list prev-content)
(list sep-element
(make-flow (make-element
(list (if parent
(make-paragraph (make-target-url
(list (if (toc-part? parent)
(make-element (derive-filename parent)
(if parent "index.html"))
(make-target-url (if prev "nonavigation")
(derive-filename prev) up-content)
"index.html")) sep-element
"nonavigation") (make-element
prev-content) (if next
sep-element (make-target-url (derive-filename next))
(make-element "nonavigation")
(if parent next-content))
(make-target-url d
(if (toc-part? parent) ri))))))
(derive-filename parent)
"index.html"))
"nonavigation")
up-content)
sep-element
(make-element
(if next
(make-target-url (derive-filename next))
"nonavigation")
next-content))))))))
d
ri)))))
(define/override (render-part d ri) (define/override (render-part d ri)
(parameterize ([current-version (parameterize ([current-version
@ -796,20 +810,9 @@
[on-separate-page #f]) [on-separate-page #f])
(if sep? (if sep?
;; Navigation bars; ;; Navigation bars;
`(,@(navigation d ri) `(,@(super render-version d ri)
,@(navigation d ri)
(p nbsp) (p nbsp)
,@(render-table (make-table
"versionbox"
(list
(list
(make-flow
(list
(make-paragraph (list
(make-element "version"
(list "Version: "
(current-version))))))))))
d
ri)
,@(super render-part d ri) ,@(super render-part d ri)
(p nbsp) (p nbsp)
,@(navigation d ri) ,@(navigation d ri)

926
collects/scribble/scribble.css
View File

@ -1,497 +1,431 @@
body { body {
color: black; color: black;
background-color: #ffffff; background-color: #ffffff;
} }
table td { table td {
padding-left: 0; padding-left: 0;
padding-right: 0; padding-right: 0;
} }
.maincolumn { .maincolumn {
font-family: monospace; font-family: monospace;
width: 43em; width: 43em;
margin-right: -40em; margin-right: -40em;
margin-left: 15em; margin-left: 15em;
} }
.main { .main {
font-family: serif; font-family: serif;
text-align: left; text-align: left;
} }
.versionbox { .navleft {
position: relative; position: relative;
float: right; float: left;
left: 3em; }
top: -2em; .navright {
height: 0em; position: relative;
width: 13em; float: right;
margin: 0em -13em 0em 0em; }
}
.version { .versionbox {
font-family: sans-serif; position: relative;
float: right;
} left: 3em;
height: 0em;
.refpara { width: 13em;
font-family: monospace; margin: 0em -13em 0em 0em;
position: relative; }
float: right; .version {
left: 1em; font-family: sans-serif;
top: -1em; font-size: small;
height: 0em; }
width: 13em;
margin: 0em -13em 0em 0em; .refpara {
} font-family: monospace;
position: relative;
.refcolumn { float: right;
background-color: #F5F5DC; left: 1em;
display: block; top: -1em;
position: relative; height: 0em;
width: 13em; width: 13em;
font-size: 85%; margin: 0em -13em 0em 0em;
border: 0.5em solid #F5F5DC; }
}
.refcolumn {
.refcontent { background-color: #F5F5DC;
font-family: serif; display: block;
} position: relative;
width: 13em;
.tocset { font-size: 85%;
font-family: monospace; border: 0.5em solid #F5F5DC;
position: relative; }
float: left;
width: 12.5em; .refcontent {
margin-right: 2em; font-family: serif;
} }
.tocview { .tocset {
font-family: serif; font-family: monospace;
text-align: left; position: relative;
background-color: #F5F5DC; float: left;
} width: 12.5em;
margin-right: 2em;
.tocsub { }
font-family: serif;
margin-top: 1em; .tocview {
text-align: left; font-family: serif;
background-color: #DCF5F5; text-align: left;
} background-color: #F5F5DC;
}
.tocviewtitle {
font-size: 80%; .tocsub {
font-weight: bold; font-family: serif;
margin: 0.2em 0.2em 0.2em 0.2em; margin-top: 1em;
} text-align: left;
background-color: #DCF5F5;
.tocviewlist { }
margin: 0.2em 0.2em 0.2em 0.2em;
} .tocviewtitle {
font-size: 80%;
.tocviewlist td { font-weight: bold;
font-size: 80%; margin: 0.2em 0.2em 0.2em 0.2em;
vertical-align: top; }
}
.tocviewlist {
.tocviewlink { margin: 0.2em 0.2em 0.2em 0.2em;
text-decoration: none; }
}
.tocviewlist td {
.tocsublist { font-size: 80%;
margin: 0.2em 0.2em 0.2em 0.2em; vertical-align: top;
} }
.tocsublist td { .tocviewlink {
vertical-align: top; text-decoration: none;
padding-left: 1em; }
text-indent: -1em;
} .tocsublist {
margin: 0.2em 0.2em 0.2em 0.2em;
.tocsublinknumber { }
font-size: 80%;
} .tocsublist td {
vertical-align: top;
.tocsublink { padding-left: 1em;
text-decoration: none; text-indent: -1em;
} }
.tocsubseclink { .tocsublinknumber {
font-size: 80%; font-size: 80%;
text-decoration: none; }
}
.tocsublink {
.tocsubtitle { text-decoration: none;
font-size: 80%; }
font-style: italic;
margin: 0.2em 0.2em 0.2em 0.2em; .tocsubseclink {
} font-size: 80%;
text-decoration: none;
.leftindent { }
margin-left: 1em;
margin-right: 0em; .tocsubtitle {
} font-size: 80%;
font-style: italic;
.insetpara { margin: 0.2em 0.2em 0.2em 0.2em;
margin-left: 1em; }
margin-right: 1em;
} .leftindent {
margin-left: 1em;
.toclink { margin-right: 0em;
text-decoration: none; }
color: blue;
font-size: 85%; .insetpara {
} margin-left: 1em;
margin-right: 1em;
.toptoclink { }
text-decoration: none;
color: blue; .toclink {
font-weight: bold; text-decoration: none;
} color: blue;
font-size: 85%;
.inherited { }
width: 100%;
margin-top: 1em; .toptoclink {
text-align: left; text-decoration: none;
background-color: #ECF5F5; color: blue;
} font-weight: bold;
}
.inherited td {
padding-left: 1em; .inherited {
text-indent: -0.8em; width: 100%;
padding-right: 0.2em; margin-top: 1em;
} text-align: left;
background-color: #ECF5F5;
.inheritedlbl { }
font-style: italic;
font-size: 85%; .inherited td {
} padding-left: 1em;
text-indent: -0.8em;
.indexlink { padding-right: 0.2em;
text-decoration: none; }
}
.inheritedlbl {
.nobreak { font-style: italic;
white-space: nowrap; font-size: 85%;
} }
.stt { .indexlink {
font-family: monospace; text-decoration: none;
} }
.title { .nobreak {
font-size: 200%; white-space: nowrap;
font-weight: normal; }
margin-top: 2.8em;
text-align: center; .stt {
} font-family: monospace;
}
.partheading {
font-size: 100%; .title {
} font-size: 200%;
font-weight: normal;
.chapterheading { margin-top: 2.8em;
font-size: 100%; text-align: center;
} }
.beginsection { .partheading {
font-size: 110%; font-size: 100%;
} }
.tiny { .chapterheading {
font-size: 40%; font-size: 100%;
} }
.scriptsize { .beginsection {
font-size: 60%; font-size: 110%;
} }
.footnotesize { pre {
font-size: 75%; margin-left: 2em;
} }
.small { blockquote {
font-size: 90%; margin-left: 2em;
} }
.normalsize { ol {
font-size: 100%; list-style-type: decimal;
} }
.large { ol ol {
font-size: 120%; list-style-type: lower-alpha;
} }
.largecap { ol ol ol {
font-size: 150%; list-style-type: lower-roman;
} }
.largeup { ol ol ol ol {
font-size: 200%; list-style-type: upper-alpha;
} }
.huge { i {
font-size: 300%; font-family: serif;
} }
.hugecap { .boxed {
font-size: 350%; width: 100%;
} background-color: #E8E8FF;
}
pre {
margin-left: 2em; .together {
} width: 100%;
}
blockquote {
margin-left: 2em; .prototype td {
} vertical-align: top;
}
ol { .longprototype td {
list-style-type: decimal; vertical-align: bottom;
} }
ol ol { .schemeblock td {
list-style-type: lower-alpha; vertical-align: baseline;
} }
ol ol ol { .argcontract td {
list-style-type: lower-roman; vertical-align: top;
} }
ol ol ol ol { .centered {
list-style-type: upper-alpha; horiz-align: center;
} }
i { .verbatim em {
font-family: serif; font-family: serif;
} }
.boxed { .ghost {
width: 100%; color: white;
background-color: #E8E8FF; }
}
.scheme em {
.together { color: black;
width: 100%; font-family: serif;
} }
.prototype td { .highlighted {
vertical-align: top; background-color: #ddddff;
} }
.longprototype td {
vertical-align: bottom; .defmodule {
} width: 100%;
background-color: #F5F5DC;
.schemeblock td { }
vertical-align: baseline;
} .specgrammar {
float: right;
.argcontract td { }
vertical-align: top;
} .hspace {
font-family: monospace;
.centered { }
horiz-align: center;
} .inferencetop td {
border-bottom: 1px solid black;
.verbatim em { text-align: center;
font-family: serif; }
} .inferencebottom td {
text-align: center;
.ghost { }
color: white;
} .schemeinput {
color: brown;
.scheme em { background-color: #eeeeee;
color: black; font-family: monospace;
font-family: serif; }
}
.schemeinputbg {
.highlighted { background-color: #eeeeee;
background-color: #ddddff; }
}
.schemereader {
.defmodule { font-family: monospace;
width: 100%; }
background-color: #F5F5DC;
} .schemeparen {
color: #843c24;
.specgrammar { font-family: monospace;
float: right; }
}
.schememeta {
.hspace { color: #262680;
font-family: monospace; font-family: monospace;
} }
.small { .schememod {
font-size: 80%; color: black;
} font-family: monospace;
}
.inferencetop td {
border-bottom: 1px solid black; .schemeopt {
text-align: center; color: black;
} }
.inferencebottom td {
text-align: center; .schemekeyword {
} color: black;
font-weight: bold;
.schemeinput { font-family: monospace;
color: brown; }
background-color: #eeeeee;
font-family: monospace; .schemeerror {
} color: red;
font-style: italic;
.schemeinputbg { }
background-color: #eeeeee;
} .schemevariable {
color: #262680;
.schemereader { font-style: italic;
font-family: monospace; font-family: monospace;
} }
.schemeparen { .schemesymbol {
color: #843c24; color: #262680;
font-family: monospace; font-family: monospace;
} }
.schememeta { .schemevaluelink {
color: #262680; text-decoration: none;
font-family: monospace; color: blue;
} }
.schememod { .schememodlink {
color: black; text-decoration: none;
font-family: monospace; color: blue;
} }
.schemeopt { .schemesyntaxlink {
color: black; text-decoration: none;
} color: black;
font-weight: bold;
.schemekeyword { }
color: black;
font-weight: bold; .badlink {
font-family: monospace; text-decoration: underline;
} color: red;
}
.schemeerror {
color: red; .plainlink {
font-style: italic; text-decoration: none;
} color: blue;
}
.schemevariable {
color: #262680; .techlink {
font-style: italic; text-decoration: none;
font-family: monospace; color: black;
} }
.schemesymbol { .techlink:hover {
color: #262680; text-decoration: underline;
font-family: monospace; color: blue;
} }
.schemevaluelink { .schemeresult {
text-decoration: none; color: #0000af;
color: blue; font-family: monospace;
} }
.schememodlink { .schemestdout {
text-decoration: none; color: #960096;
color: blue; font-family: monospace;
} }
.schemesyntaxlink { .schemecomment {
text-decoration: none; color: #c2741f;
color: black; font-family: monospace;
font-weight: bold; }
}
.schemevalue {
.badlink { color: #228b22;
text-decoration: underline; font-family: monospace;
color: red; }
}
.bibliography td {
.plainlink { vertical-align: top;
text-decoration: none; }
color: blue;
} .imageleft {
float: left;
.techlink { margin-right: 0.3em;
text-decoration: none; }
color: black;
} .nonavigation {
.techlink:hover { color: #EEEEEE;
text-decoration: underline; }
color: blue;
} .mywbr {
width: 0;
.schemeresult { font-size: 1px;
color: #0000af; }
font-family: monospace;
}
.schemestdout {
color: #960096;
font-family: monospace;
}
.schemecomment {
color: #c2741f;
font-family: monospace;
}
.schemevalue {
color: #228b22;
font-family: monospace;
}
.bibliography td {
vertical-align: top;
}
.imageleft {
float: left;
margin-right: 0.3em;
}
.nonavigation {
color: #EEEEEE;
}
.disable {
/* color: #e5e5e5; */
color: gray;
}
.smallcaps {
font-size: 75%;
}
.smallprint {
color: gray;
font-size: 75%;
text-align: right;
}
.footnoterule {
text-align: left;
width: 40%;
}
.colophon {
color: gray;
font-size: 80%;
font-style: italic;
text-align: right;
}
.colophon a {
color: gray;
}
.mywbr {
width: 0;
font-size: 1px;
}

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" (always-run)))) (define scribblings '(("start.scrbl" (main-doc-root always-run))))
(define doc-categories '(omit))) (define doc-categories '(omit)))

79
collects/setup/path-relativize.ss
View File

@ -17,59 +17,58 @@
;; `path->main-collects-relative' misses some usages, as long as it ;; `path->main-collects-relative' misses some usages, as long as it
;; works when we prepare a distribution tree. Otherwise, things ;; works when we prepare a distribution tree. Otherwise, things
;; will continue to work fine and .dep files will just contain ;; will continue to work fine and .dep files will just contain
;; absolute path names. These functions work on .dep elements: ;; absolute path names.
;; either a pathname or a pair with a pathname in its cdr; the
;; `path->main-collects-relative' pathname will itself be a pair.
;; We need to compare paths to find when something is in the plt ;; We need to compare paths to find when something is in the plt
;; tree -- this does some basic "normalization" that should work ;; tree, so we explode the paths. This slower than the old way (by
;; fine: getting rid of `.' and `..', collapsing multiple ;; a factor of 2 or so), but it's simpler and more portable.
;; `/'s to one `/', and converting '/'s to '\'s under Windows. (define (explode-path* path)
(define (simplify-path* bytes) (explode-path (simplify-path (path->complete-path path))))
(path->bytes (normal-case-path (simplify-path (bytes->path bytes)))))
(define (explode-path orig-path)
(let loop ([path orig-path][rest null])
(let-values ([(base name dir?) (split-path path)])
(if (path? base)
(loop base (cons name rest))
(cons name rest)))))
(define main-collects-dir/ (define main-collects-dir/
(delay (let ([dir (find-main-dir)]) (delay (let ([dir (find-main-dir)])
(and dir (simplify-path* (path->bytes (path->directory-path dir))))))) (and dir (explode-path* dir)))))
(define (maybe-cdr-op fname f)
(lambda (x)
(cond [(and (pair? x) (not (eq? tag (car x))))
(cons (car x) (f (cdr x)))]
[else (f x)])))
;; path->main-collects-relative* : path-or-bytes -> datum-containing-bytes-or-path ;; path->main-collects-relative* : path-or-bytes -> datum-containing-bytes-or-path
(define (path->main-collects-relative* path) (define (path->main-relative* path)
(let* ([path (cond [(bytes? path) path] (let loop ([exploded (explode-path* (if (bytes? path)
[(path? path) (path->bytes path)] (bytes->path path)
[else (error 'path->main-collects-relative path))]
"expecting a byte-string, got ~e" path)])] [main-exploded (force main-collects-dir/)])
[path* (simplify-path* path)] (cond
[main-collects-dir/ (force main-collects-dir/)] [(null? main-exploded) (cons tag (map path-element->bytes exploded))]
[mcd-len (bytes-length main-collects-dir/)]) [(null? exploded) path]
(cond [(and path* [(equal? (normal-case-path (car exploded))
mcd-len (normal-case-path (car main-exploded)))
(> (bytes-length path*) mcd-len) (loop (cdr exploded) (cdr main-exploded))]
(equal? (subbytes path* 0 mcd-len) [else path])))
main-collects-dir/))
(cons tag (subbytes path* mcd-len))]
[(equal? path* main-collects-dir/) (cons tag #"")]
[else path])))
;; main-collects-relative->path* : datum-containing-bytes-or-path -> path ;; main-collects-relative->path* : datum-containing-bytes-or-path -> path
(define (main-collects-relative->path* path) (define (main-relative->path* path)
(cond [(and (pair? path) (cond [(and (pair? path)
(eq? tag (car path)) (eq? tag (car path))
(bytes? (cdr path))) (or (bytes? (cdr path)) ; backward compatibility
(and (list? (cdr path))
(andmap bytes? (cdr path)))))
(let ([dir (or (find-main-dir) (let ([dir (or (find-main-dir)
;; No main "collects"/"doc"/whatever? Use original working directory: ;; No main "collects"/"doc"/whatever? Use original working directory:
(find-system-path 'orig-dir))]) (find-system-path 'orig-dir))])
(if (equal? (cdr path) #"") (if (bytes? (cdr path))
dir ;; backward compatibilty:
(build-path dir (bytes->path (cdr path)))))] (if (equal? (cdr path) #"")
[(bytes? path) (bytes->path path)] dir
(build-path dir (bytes->path (cdr path))))
;; Normal mode:
(apply build-path dir
(map bytes->path-element (cdr path)))))]
[else path])) [else path]))
(values (values path->main-relative*
(maybe-cdr-op to-rel-name path->main-collects-relative*) main-relative->path*)))
(maybe-cdr-op from-rel-name main-collects-relative->path*))))

41
collects/setup/scribble.ss
View File

@ -16,7 +16,7 @@
(define verbose (make-parameter #t)) (define verbose (make-parameter #t))
(define-struct doc (src-dir src-file dest-dir flags)) (define-struct doc (src-dir src-file dest-dir flags under-main?))
(define-struct info (doc sci provides undef searches deps (define-struct info (doc sci provides undef searches deps
build? time out-time need-run? build? time out-time need-run?
need-in-write? need-out-write? need-in-write? need-out-write?
@ -38,6 +38,7 @@
(and (list? (cadr v)) (and (list? (cadr v))
(andmap (lambda (i) (andmap (lambda (i)
(member i '(main-doc (member i '(main-doc
main-doc-root
multi-page multi-page
always-run))) always-run)))
(cadr v)) (cadr v))
@ -46,7 +47,10 @@
(relative-path? (caddr v)))))))) (relative-path? (caddr v))))))))
s)) s))
(map (lambda (d) (map (lambda (d)
(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))
(or (memq 'main-doc flags)
(pair? (path->main-collects-relative dir))))])
(make-doc dir (make-doc dir
(build-path dir (car d)) (build-path dir (car d))
(let ([name (if (and (pair? (cdr d)) (let ([name (if (and (pair? (cdr d))
@ -55,11 +59,13 @@
(cadr d) (cadr d)
(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 #"")))])
(if (or (memq 'main-doc flags) (if (memq 'main-doc-root flags)
(pair? (path->main-collects-relative dir))) (find-doc-dir)
(build-path (find-doc-dir) name) (if under-main?
(build-path dir "doc" name))) (build-path (find-doc-dir) name)
flags))) (build-path dir "doc" name))))
flags
under-main?)))
s) s)
(begin (begin
(fprintf (current-error-port) (fprintf (current-error-port)
@ -174,7 +180,10 @@
[dest-dir (if (memq 'multi-page (doc-flags doc)) [dest-dir (if (memq 'multi-page (doc-flags doc))
(let-values ([(base name dir?) (split-path (doc-dest-dir doc))]) (let-values ([(base name dir?) (split-path (doc-dest-dir doc))])
base) base)
(doc-dest-dir doc))]))) (doc-dest-dir doc))]
[css-path (if (doc-under-main? doc)
"../scribble.css"
#f)])))
(define (pick-dest latex-dest doc) (define (pick-dest latex-dest doc)
(if latex-dest (if latex-dest
@ -269,7 +278,7 @@
(list-ref v-out 2) ; provides (list-ref v-out 2) ; provides
(list-ref v-in 1) ; undef (list-ref v-in 1) ; undef
(list-ref v-in 3) ; searches (list-ref v-in 3) ; searches
(map string->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 can-run? (memq 'always-run (doc-flags doc))) (and can-run? (memq 'always-run (doc-flags doc)))
@ -399,7 +408,7 @@
(list (list (info-vers info) (doc-flags doc)) (list (list (info-vers info) (doc-flags doc))
(info-undef info) (info-undef info)
(map (lambda (i) (map (lambda (i)
(path->string (doc-src-file (info-doc i)))) (path->rel (doc-src-file (info-doc i))))
(info-deps info)) (info-deps info))
(info-searches info)))))))))) (info-searches info))))))))))
@ -409,3 +418,15 @@
(define (write-in info) (define (write-in info)
(make-directory* (doc-dest-dir (info-doc info))) (make-directory* (doc-dest-dir (info-doc info)))
(write- info "in.sxref" (lambda (o i) i))) (write- info "in.sxref" (lambda (o i) i)))
(define (rel->path r)
(if (bytes? r)
(bytes->path r)
(main-collects-relative->path r)))
(define (path->rel r)
(let ([r (path->main-collects-relative r)])
(if (path? r)
(path->bytes r)
r)))

25
collects/setup/setup-unit.ss
View File

@ -18,8 +18,6 @@
compiler/sig compiler/sig
launcher/launcher-sig launcher/launcher-sig
(prefix-in doc: "scribble.ss")
"unpack.ss" "unpack.ss"
"getinfo.ss" "getinfo.ss"
"dirs.ss" "dirs.ss"
@ -412,9 +410,11 @@
(with-input-from-file path read))]) (with-input-from-file path read))])
(when (and (pair? deps) (list? deps)) (when (and (pair? deps) (list? deps))
(for ([s (cdr deps)]) (for ([s (cdr deps)])
(let ([s (main-collects-relative->path s)]) (unless (and (pair? s)
(when (path-string? s) (eq? 'ext (car s)))
(hash-table-put! dependencies s #t))))))) (let ([s (main-collects-relative->path s)])
(when (path-string? s)
(hash-table-put! dependencies s #t))))))))
(delete-file path)) (delete-file path))
(define (delete-files-in-directory path printout dependencies) (define (delete-files-in-directory path printout dependencies)
@ -738,16 +738,23 @@
;; Docs ;; ;; Docs ;;
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (doc:verbose)
(parameterize ([current-namespace (namespace-anchor->empty-namespace anchor)])
(dynamic-require 'setup/scribble 'verbose)))
(define (doc:setup-scribblings)
(parameterize ([current-namespace (namespace-anchor->empty-namespace anchor)])
(dynamic-require 'setup/scribble 'setup-scribblings)))
(when (make-docs) (when (make-docs)
(setup-printf "Building documentation") (setup-printf "Building documentation")
(doc:verbose (verbose)) ((doc:verbose) (verbose))
(with-handlers ([exn:fail? (lambda (exn) (with-handlers ([exn:fail? (lambda (exn)
(setup-printf (setup-printf
"Docs failure: ~a" "Docs failure: ~a"
(if (exn? exn) (if (exn? exn)
(exn-message exn) (exn-message exn)
exn)))]) exn)))])
(doc:setup-scribblings ((doc:setup-scribblings)
(if no-specific-collections? #f (map cc-path ccs-to-compile)) (if no-specific-collections? #f (map cc-path ccs-to-compile))
#f))) #f)))
@ -789,8 +796,8 @@
void void
(lambda () (lambda ()
(make-directory tmp-dir) (make-directory tmp-dir)
(doc:verbose (verbose)) ((doc:verbose) (verbose))
(doc:setup-scribblings ((doc:setup-scribblings)
(if no-specific-collections? #f (map cc-path ccs-to-compile)) (if no-specific-collections? #f (map cc-path ccs-to-compile))
tmp-dir) tmp-dir)
(parameterize ([current-directory tmp-dir]) (parameterize ([current-directory tmp-dir])

10
collects/setup/xref.ss
View File

@ -18,10 +18,12 @@
(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 (or (memq 'main-doc flags) (if (memq 'main-doc-root flags)
(pair? (path->main-collects-relative dir))) (find-doc-dir)
(build-path (find-doc-dir) name) (if (or (memq 'main-doc flags)
(build-path dir "compiled" "doc" name)) (pair? (path->main-collects-relative dir)))
(build-path (find-doc-dir) name)
(build-path dir "compiled" "doc" name)))
"out.sxref")) "out.sxref"))
#f)) #f))
((get-info/full dir) 'scribblings))) ((get-info/full dir) 'scribblings)))