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

[setup-unit] cleanup ccs-to-compile, move invocations to bottom of unit

Browse Source 
svn: r18741
This commit is contained in:
Kevin Tew 2010-04-06 20:56:28 +00:00
parent aec586d2be
commit 63b819ce74
1 changed files with 80 additions and 78 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -49,6 +49,11 @@
(define name-str (setup-program-name)) (define name-str (setup-program-name))
(define name-sym (string->symbol name-str)) (define name-sym (string->symbol name-str))
(define main-collects-dir (find-collects-dir))
(define mode-dir
(if (compile-mode)
(build-path "compiled" (compile-mode))
(build-path "compiled")))
(define (setup-fprintf p task s . args) (define (setup-fprintf p task s . args)
(let ([task (if task (string-append task ": ") "")]) (let ([task (if task (string-append task ": ") "")])
@ -66,35 +71,10 @@
(define (relative-path-string? x) (and (path-string? x) (relative-path? x))) (define (relative-path-string? x) (and (path-string? x) (relative-path? x)))
(define main-collects-dir (find-collects-dir))
(unless (make-user)
(current-library-collection-paths
(if (member main-collects-dir (current-library-collection-paths))
(list main-collects-dir)
'())))
(current-library-collection-paths
(map simplify-path (current-library-collection-paths)))
(setup-printf "version" "~a [~a]" (version) (system-type 'gc))
(setup-printf "variants" "~a"
(string-join (map symbol->string (available-mzscheme-variants))
", "))
(setup-printf "main collects" "~a" (path->string main-collects-dir))
(setup-printf "collects paths"
(if (null? (current-library-collection-paths)) " empty!" ""))
(for ([p (current-library-collection-paths)])
(setup-printf #f " ~a" (path->string p)))
(define (call-info info flag mk-default test) (define (call-info info flag mk-default test)
(let ([v (info flag mk-default)]) (test v) v)) (let ([v (info flag mk-default)]) (test v) v))
(define mode-dir
(if (compile-mode)
(build-path "compiled" (compile-mode))
(build-path "compiled")))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Errors ;; ;; Errors ;;
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -157,10 +137,6 @@
(define no-specific-collections? (define no-specific-collections?
(and (null? x-specific-collections) (null? x-specific-planet-dirs))) (and (null? x-specific-collections) (null? x-specific-planet-dirs)))
(when (and (not (null? (archives))) no-specific-collections?)
(done)
(exit 0)) ; done
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Find Collections ;; ;; Find Collections ;;
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -257,15 +233,6 @@
maj maj
min))) min)))
(define planet-dirs-to-compile
(if (make-planet)
(filter-map (lambda (spec) (apply planet->cc spec))
(if no-specific-collections?
(get-all-planet-packages)
(filter-map planet-spec->planet-list
x-specific-planet-dirs)))
null))
(define all-collections (define all-collections
(let ([ht (make-hash)]) (let ([ht (make-hash)])
(for ([cp (current-library-collection-paths)] (for ([cp (current-library-collection-paths)]
@ -348,29 +315,34 @@
(define (sort-collections ccs) (define (sort-collections ccs)
(sort ccs string<? #:key cc-name)) (sort ccs string<? #:key cc-name))
(define collections-to-compile (define ccs-to-compile
(sort-collections (let ([planet-dirs-to-compile
(plt-collection-closure (sort-collections
(if no-specific-collections? (collection-closure
all-collections (if (make-planet)
(check-again-all (filter-map (lambda (spec) (apply planet->cc spec))
(filter-map (if no-specific-collections?
(lambda (c) (get-all-planet-packages)
(collection->cc (append-map (lambda (s) (filter-map planet-spec->planet-list
(map string->path x-specific-planet-dirs)))
(regexp-split #rx"/" s))) null)
c))) (lambda (cc subs)
x-specific-collections)))))) (map (lambda (p) (planet-cc->sub-cc cc (list (path->bytes p))))
subs))))]
(set! planet-dirs-to-compile [collections-to-compile
(sort-collections (sort-collections
(collection-closure (plt-collection-closure
planet-dirs-to-compile (if no-specific-collections?
(lambda (cc subs) all-collections
(map (lambda (p) (planet-cc->sub-cc cc (list (path->bytes p)))) (check-again-all
subs))))) (filter-map
(lambda (c)
(define ccs-to-compile (append collections-to-compile planet-dirs-to-compile)) (collection->cc (append-map (lambda (s)
(map string->path
(regexp-split #rx"/" s)))
c)))
x-specific-collections)))))])
(append collections-to-compile planet-dirs-to-compile)))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Clean ;; ;; Clean ;;
@ -452,7 +424,7 @@
(print-message)] (print-message)]
[else (void)]))))))) [else (void)])))))))
(when (clean) (define (clean-step)
(setup-printf #f "--- cleaning collections ---") (setup-printf #f "--- cleaning collections ---")
(let ([dependencies (make-hash)]) (let ([dependencies (make-hash)])
;; Main deletion: ;; Main deletion:
@ -484,10 +456,6 @@
(with-handlers ([exn:fail:filesystem? (warning-handler (void))]) (with-handlers ([exn:fail:filesystem? (warning-handler (void))])
(with-output-to-file fn void #:exists 'truncate/replace)))))))) (with-output-to-file fn void #:exists 'truncate/replace))))))))
(when (make-zo)
(compiler:option:verbose (compiler-verbose))
(compiler:option:compile-subcollections #f))
(define (do-install-part part) (define (do-install-part part)
(when (if (eq? part 'post) (call-post-install) (call-install)) (when (if (eq? part 'post) (call-post-install) (call-install))
(setup-printf #f (format "--- ~ainstalling collections ---" (setup-printf #f (format "--- ~ainstalling collections ---"
@ -536,8 +504,6 @@
(installer dir (cc-path cc)) (installer dir (cc-path cc))
(installer dir)))))))))) (installer dir))))))))))
(do-install-part 'pre)
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Make zo ;; ;; Make zo ;;
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -617,7 +583,7 @@
;; To avoid keeping modules in memory across collections, pass ;; To avoid keeping modules in memory across collections, pass
;; `make-base-namespace' as `get-namespace', otherwise use ;; `make-base-namespace' as `get-namespace', otherwise use
;; `current-namespace' for `get-namespace'. ;; `current-namespace' for `get-namespace'.
(when (make-zo) (define (make-zo-step)
(setup-printf #f "--- compiling collections ---") (setup-printf #f "--- compiling collections ---")
(with-specified-mode (with-specified-mode
(let ([gc? #f]) (let ([gc? #f])
@ -636,7 +602,7 @@
;; Info-Domain Cache ;; ;; Info-Domain Cache ;;
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(when (make-info-domain) (define (make-info-domain-step)
(setup-printf #f "--- updating info-domain tables ---") (setup-printf #f "--- updating info-domain tables ---")
;; Each ht maps a collection root dir to an info-domain table. Even when ;; Each ht maps a collection root dir to an info-domain table. Even when
;; `collections-to-compile' is a subset of all collections, we only care ;; `collections-to-compile' is a subset of all collections, we only care
@ -733,11 +699,6 @@
;; Docs ;; ;; Docs ;;
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(when (make-docs)
;; Double-check that "setup/scribble" is present.
(unless (file-exists? (build-path (collection-path "setup") "scribble.ss"))
(make-docs #f)))
(define (scr:call name . xs) (define (scr:call name . xs)
(parameterize ([current-namespace (parameterize ([current-namespace
(namespace-anchor->empty-namespace anchor)]) (namespace-anchor->empty-namespace anchor)])
@ -753,7 +714,7 @@
(lambda (what go alt) (record-error what "Building docs" go alt)) (lambda (what go alt) (record-error what "Building docs" go alt))
setup-printf)) setup-printf))
(when (make-docs) (define (make-docs-step)
(setup-printf #f "--- building documentation ---") (setup-printf #f "--- building documentation ---")
(set-doc:verbose) (set-doc:verbose)
(with-handlers ([exn:fail? (with-handlers ([exn:fail?
@ -762,7 +723,7 @@
(doc:setup-scribblings #f (and (not (null? (archives))) (doc:setup-scribblings #f (and (not (null? (archives)))
(archive-implies-reindex))))) (archive-implies-reindex)))))
(when (doc-pdf-dest) (define (doc-pdf-dest-step)
(setup-printf #f "building PDF documentation (via pdflatex)") (setup-printf #f "building PDF documentation (via pdflatex)")
(let ([dest-dir (path->complete-path (doc-pdf-dest))]) (let ([dest-dir (path->complete-path (doc-pdf-dest))])
(unless (directory-exists? dest-dir) (unless (directory-exists? dest-dir)
@ -792,7 +753,7 @@
;; Make Launchers ;; ;; Make Launchers ;;
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(when (make-launchers) (define (make-launchers-step)
(setup-printf #f "--- creating launchers ---") (setup-printf #f "--- creating launchers ---")
(let ([name-list (let ([name-list
(lambda (l) (lambda (l)
@ -892,6 +853,47 @@
make-mzscheme-launcher make-mzscheme-launcher
mzscheme-launcher-up-to-date?))))))) mzscheme-launcher-up-to-date?)))))))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; setup-unit Body ;;
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(unless (make-user)
(current-library-collection-paths
(if (member main-collects-dir (current-library-collection-paths))
(list main-collects-dir)
'())))
(current-library-collection-paths
(map simplify-path (current-library-collection-paths)))
(setup-printf "version" "~a [~a]" (version) (system-type 'gc))
(setup-printf "variants" "~a" (string-join (map symbol->string (available-mzscheme-variants)) ", "))
(setup-printf "main collects" "~a" (path->string main-collects-dir))
(setup-printf "collects paths" (if (null? (current-library-collection-paths)) " empty!" ""))
(for ([p (current-library-collection-paths)])
(setup-printf #f " ~a" (path->string p)))
(when (and (not (null? (archives))) no-specific-collections?)
(done))
(when (clean) (clean-step))
(when (make-zo)
(compiler:option:verbose (compiler-verbose))
(compiler:option:compile-subcollections #f))
(do-install-part 'pre)
(when (make-zo) (make-zo-step))
(when (make-info-domain) (make-info-domain-step))
(when (make-docs)
;; Double-check that "setup/scribble" is present.
(unless (file-exists? (build-path (collection-path "setup") "scribble.ss"))
(make-docs-step)))
(when (doc-pdf-dest) (doc-pdf-dest-step))
(when (make-launchers) (make-launchers-step))
(do-install-part 'general) (do-install-part 'general)
(do-install-part 'post) (do-install-part 'post)