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

* A more noticeable message for starting the doc build

Browse Source 
* More paths relative to known places

svn: r10028
This commit is contained in:
Eli Barzilay 2008-05-30 02:32:49 +00:00
parent d40b191eb7
commit b43b66ae37
2 changed files with 50 additions and 35 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

29
collects/setup/private/path-utils.ss
View File

@ -2,6 +2,7 @@
(require setup/dirs
setup/main-collects
setup/path-relativize
scheme/list)
(provide doc-path path->name)
@ -21,13 +22,27 @@
;; printouts during compilation, so the input path is usually
;; complete, otherwise it can be ambiguous, so use only when it's
;; clear from the context what path is shown. (To be used only for
;; human-readable output.)
(define (path->name path)
;; human-readable output.) Generalized for any base directory and an
;; indicative prefix.
(define (path->rel path find-base)
((if (not find-base)
path->main-collects-relative
(let-values ([(path->rel rel->path)
(make-relativize find-base 'rel 'path->rel 'rel->path)])
path->rel))
path))
(define (path->name path #:prefix [prefix #f] #:base [find-base #f])
(if (not (complete-path? path))
(if (string? path) path (path->string path))
(let ([rel (path->main-collects-relative path)])
(let loop ([rel (path->rel path find-base)]
[prefix prefix])
(if (pair? rel)
(bytes->string/utf-8
(apply bytes-append
(cdr (append-map (lambda (p) (list #"/" p)) (cdr rel)))))
(path->string rel)))))
(let* ([p (cdr (append-map (lambda (p) (list #"/" p)) (cdr rel)))]
[p (bytes->string/utf-8 (apply bytes-append p))])
(if prefix (format "<~a>/~a" prefix p) p))
(if (or prefix find-base)
(path->string rel)
;; by default (both optionals missing) try the user
;; collections too looping with a prefix avoids trying this
;; again
(loop (path->rel path find-user-collects-dir) 'user))))))

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

@ -1,6 +1,5 @@
; Expects parameters to be set before invocation.
; Calls `exit' when done.
;; Expects parameters to be set before invocation.
;; Calls `exit' when done.
#lang scheme/base
@ -47,14 +46,8 @@
(export)
(define (setup-fprintf p task s . args)
(apply fprintf p (string-append "setup-plt: "
(if task
(string-append
task
": ")
"")
s
"\n") args))
(let ([task (if task (string-append task ": ") "")])
(apply fprintf p (string-append "setup-plt: " task s "\n") args)))
(define (setup-printf task s . args)
(apply setup-fprintf (current-output-port) task s args))
@ -585,7 +578,10 @@
[(general) 'installer]
[(post) 'post-installer])))])
(setup-printf (format "~ainstalling"
(case part [(pre) "pre-"] [(post) "post-"] [else ""]))
(case part
[(pre) "pre-"]
[(post) "post-"]
[else ""]))
"~a"
(cc-name cc))
(let ([dir (build-path main-collects-dir 'up)])
@ -791,7 +787,7 @@
(dynamic-require 'setup/scribble 'setup-scribblings)))
(when (make-docs)
(setup-printf #f "building documentation")
(setup-printf #f "--- building documentation ---")
((doc:verbose) (verbose))
(with-handlers ([exn:fail?
(lambda (exn)
@ -897,7 +893,7 @@
(unless (null? mzlns)
(setup-printf
"WARNING"
"~a launcher name list ~s has no matching library/flags lists"
"~s launcher name list ~s has no matching library/flags lists"
kind mzlns))]
[(and (or (not mzlls) (= (length mzlns) (length mzlls)))
(or (not mzlfs) (= (length mzlns) (length mzlfs))))
@ -910,15 +906,19 @@
`(relative? . ,(not absolute-installation?))
(build-aux-from-path
(build-path (cc-path cc)
(path-replace-suffix (or mzll mzln) #""))))])
(path-replace-suffix
(or mzll mzln)
#""))))])
(unless (up-to-date? p aux)
(setup-printf "launcher"
"~a [~a~a]"
(path->string p)
kind (let ([v (current-launcher-variant)])
(if (eq? v (system-type 'gc))
""
(format " ~a" v))))
(setup-printf
"launcher"
"~a~a"
(path->name p #:prefix (format "~a-bin" kind)
#:base (if (equal? kind 'console)
find-console-bin-dir
find-gui-bin-dir))
(let ([v (current-launcher-variant)])
(if (eq? v (system-type 'gc)) "" (format " [~a]" v))))
(make-launcher
(or mzlf
(if (cc-collection cc)
@ -942,13 +942,13 @@
(let ([fault (if (or (not mzlls) (= (length mzlns) (length mzlls))) 'f 'l)])
(setup-printf
"WARNING"
"~a launcher name list ~s doesn't match ~a list; ~s"
"~s launcher name list ~s doesn't match ~a list; ~s"
kind mzlns
(if (eq? 'l fault) "library" "flags")
(if (eq? fault 'l) mzlls mzlfs)))]))
(for ([variant (available-mred-variants)])
(parameterize ([current-launcher-variant variant])
(make-launcher "MrEd"
(make-launcher 'gui
'mred-launcher-names
'mred-launcher-libraries
'mred-launcher-flags
@ -957,7 +957,7 @@
mred-launcher-up-to-date?)))
(for ([variant (available-mzscheme-variants)])
(parameterize ([current-launcher-variant variant])
(make-launcher "MzScheme"
(make-launcher 'console
'mzscheme-launcher-names
'mzscheme-launcher-libraries
'mzscheme-launcher-flags