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

adjust planet client to handle nested planet invocations by re-building the doc index only once

Browse Source 
svn: r15246
This commit is contained in:
Matthew Flatt 2009-06-23 22:02:07 +00:00
parent 22384487e8
commit 53a011cf65
14 changed files with 151 additions and 71 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/compiler/cm.ss
View File

@ -10,7 +10,7 @@
make-caching-managed-compile-zo
trust-existing-zos
manager-compile-notify-handler
;manager-skip-file-handler ;; not yet tested, so not yet exported
manager-skip-file-handler
(rename-out [trace manager-trace-handler]))
(define manager-compile-notify-handler (make-parameter void))

21
collects/compiler/compiler-unit.ss
View File

@ -144,9 +144,14 @@
(let ([zo (append-zo-suffix b)])
(compile-to-zo f zo n prefix verbose? mod?)))))
(define (compile-directory dir info #:verbose [verbose? #t])
(define (compile-directory dir info #:verbose [verbose? #t] #:skip-path [orig-skip-path #f])
(define info* (or info (lambda (key mk-default) (mk-default))))
(define omit-paths (omitted-paths dir c-get-info/full))
(define skip-path (and orig-skip-path (path->bytes
(simplify-path (if (string? orig-skip-path)
(string->path orig-skip-path)
orig-skip-path)
#f))))
(unless (eq? 'all omit-paths)
(parameterize ([current-directory dir]
[current-load-relative-directory dir]
@ -156,7 +161,14 @@
(lambda (s) (fprintf op "~a\n" s)))
(manager-trace-handler))]
[manager-compile-notify-handler
(lambda (path) ((compile-notify-handler) path))])
(lambda (path) ((compile-notify-handler) path))]
[manager-skip-file-handler
(lambda (path) (and skip-path
(let ([b (path->bytes (simplify-path path #f))]
[len (bytes-length skip-path)])
(and ((bytes-length b) . > . len)
(bytes=? (subbytes b 0 len) skip-path)))
-inf.0))])
(let* ([sses (append
;; Find all .ss/.scm files:
(filter extract-base-filename/ss (directory-list))
@ -173,10 +185,11 @@
(when (and (directory-exists? p*) (not (member p omit-paths)))
(compile-directory p* (c-get-info/full p*))))))))
(define (compile-collection-zos collection . cp)
(define (compile-collection-zos collection #:skip-path [skip-path #f] . cp)
(compile-directory (apply collection-path collection cp)
(c-get-info (cons collection cp))
#:verbose #f))
#:verbose #f
#:skip-path skip-path))
(define compile-directory-zos compile-directory)

17
collects/planet/resolver.ss
View File

@ -210,6 +210,9 @@ subdirectory.
;; if #f, will not install packages and instead give an error
(define install? (make-parameter #t))
;; update doc index only once for a set of installs:
(define planet-nested-install (make-parameter #f))
;; =============================================================================
;; DIAMOND PROPERTY STUFF
;; make sure a module isn't loaded twice with two different versions
@ -535,12 +538,13 @@ subdirectory.
(apply build-path (CACHE-DIR)
(append (pkg-spec-path pkg) (list (pkg-spec-name pkg)
(number->string maj)
(number->string min))))])
(number->string min))))]
[was-nested? (planet-nested-install)])
(if (directory-exists? the-dir)
(raise (make-exn:fail
"Internal PLaneT error: trying to install already-installed package"
(current-continuation-marks)))
(begin
(parameterize ([planet-nested-install #t])
(planet-terse-log 'install (pkg-spec->string pkg))
(with-logging
(LOG-FILE)
@ -551,9 +555,14 @@ subdirectory.
;; oh man is this a bad hack!
(parameterize ([current-namespace (make-namespace)])
(let ([ipp (dynamic-require 'setup/plt-single-installer
'install-planet-package)])
'install-planet-package)]
[rud (dynamic-require 'setup/plt-single-installer
'reindex-user-documentation)])
(ipp path the-dir (list owner (pkg-spec-name pkg)
extra-path maj min))))))
extra-path maj min))
(unless was-nested?
(printf "------------- Rebuilding documentation index -------------\n")
(rud))))))
(planet-terse-log 'finish (pkg-spec->string pkg))
(make-pkg (pkg-spec-name pkg) (pkg-spec-path pkg)
maj min the-dir 'normal)))))

2
collects/planet/util.ss
View File

@ -124,6 +124,8 @@
(delete-directory/files path)
(planet-log "Trimming empty directories")
(trim-directory (CACHE-DIR) path)
(planet-log "Rebuilding documentation index")
(reindex-user-documentation)
(void))))
;; erase-metadata : pkg -> void

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

@ -21,8 +21,6 @@
(provide render-mixin
render-multi-mixin)
(xml:empty-tag-shorthand xml:html-empty-tags)
(define literal
(let ([loc (xml:make-location 0 0 0)])
(lambda strings (xml:make-cdata loc loc (string-append* strings)))))
@ -616,34 +614,35 @@
(call-with-input-file* prefix-file
(lambda (in)
(copy-port in (current-output-port))))
(xml:write-xml/content
(xml:xexpr->xml
`(html ()
(head ()
(meta ([http-equiv "content-type"]
[content "text-html; charset=utf-8"]))
,title
,(scribble-css-contents style-file css-path)
,@(map (lambda (style-file)
(install-file style-file)
(scribble-css-contents style-file #f))
(append style-extra-files
(extract-part-style-files
d
ri
'css
(lambda (p) (part-whole-page? p ri)))))
,(scribble-js-contents script-file script-path))
(body ((id ,(or (extract-part-body-id d ri)
"scribble-plt-scheme-org")))
,@(render-toc-view d ri)
(div ([class "maincolumn"])
(div ([class "main"])
,@(parameterize ([current-version (extract-version d)])
(render-version d ri))
,@(navigation d ri #t)
,@(render-part d ri)
,@(navigation d ri #f))))))))))
(parameterize ([xml:empty-tag-shorthand xml:html-empty-tags])
(xml:write-xml/content
(xml:xexpr->xml
`(html ()
(head ()
(meta ([http-equiv "content-type"]
[content "text-html; charset=utf-8"]))
,title
,(scribble-css-contents style-file css-path)
,@(map (lambda (style-file)
(install-file style-file)
(scribble-css-contents style-file #f))
(append style-extra-files
(extract-part-style-files
d
ri
'css
(lambda (p) (part-whole-page? p ri)))))
,(scribble-js-contents script-file script-path))
(body ((id ,(or (extract-part-body-id d ri)
"scribble-plt-scheme-org")))
,@(render-toc-view d ri)
(div ([class "maincolumn"])
(div ([class "main"])
,@(parameterize ([current-version (extract-version d)])
(render-version d ri))
,@(navigation d ri #t)
,@(render-part d ri)
,@(navigation d ri #f)))))))))))
(define/private (part-parent d ri)
(collected-info-parent (part-collected-info d ri)))

4
collects/scribblings/main/info.ss
View File

@ -3,12 +3,8 @@
(define scribblings
'(("start.scrbl"
(main-doc-root always-run depends-all-main no-depend-on) (omit))
("user/start.scrbl"
(user-doc-root always-run depends-all no-depend-on) (omit))
("search.scrbl" (depends-all-main no-depend-on) (omit))
("master-index.scrbl" (depends-all-main no-depend-on) (omit))
("user/search.scrbl" (user-doc depends-all no-depend-on) (omit))
("user/master-index.scrbl" (user-doc depends-all no-depend-on) (omit))
("getting-started.scrbl" () (omit))
("license.scrbl" () (omit))
("acks.scrbl" () (omit))

6
collects/scribblings/main/user/info.ss Normal file
View File

@ -0,0 +1,6 @@
#lang setup/infotab
(define scribblings
'(("start.scrbl" (user-doc-root always-run depends-all no-depend-on) (omit))
("search.scrbl" (user-doc depends-all no-depend-on) (omit))
("master-index.scrbl" (user-doc depends-all no-depend-on) (omit))))

19
collects/scribblings/mzc/make.scrbl
View File

@ -241,21 +241,14 @@ A parameter for a procedure of one argument that is called to report
compilation-manager actions, such as checking a file. The argument to
the procedure is a string.}
@;{
@defparam[manager-skip-file-handler proc (-> path? (or/c number? #f))]{
This handler is consulted for each file that is loaded. If it
returns a number, then the file is skipped (ie, not compiled),
and the number is used as the timestamp. If it returns @scheme[#f],
then the file is compiled (if necessary) as usual.
@;{Defaults to a function that checks to see if the module in the file
has already been loaded in the filesystem and, if it has, it
returns the timestamp of the .zo file for that file (or the .ss file
if the .zo file does not exist).}
Defaults to @scheme[(λ (x) #f)].
}
}
A parameter whose value is called for each file that is loaded and
needs recompilation. If the procedure returns a number, then the file
is skipped (i.e., not compiled), and the number is used as the
timestamp for the file's bytecode. If the procedure returns
@scheme[#f], then the file is compiled as usual. The default is
@scheme[(lambda (x) #f)].}
@; ----------------------------------------------------------------------

48
collects/scribblings/setup-plt/setup-plt.scrbl
View File

@ -389,7 +389,7 @@ initialized between them, e.g.:
_...)
]
@subsubsection{@|setup-plt| Unit}
@subsection{@|setup-plt| Unit}
@defmodule[setup/setup-unit]
@ -459,6 +459,10 @@ form.}
If on, update @filepath{info-domain/compiled/cache.ss} for each
collection path. @defaults[@scheme[#t]]}
@defboolparam[avoid-main-installation on?]{
If on, avoid building bytecode in the main installation tree when building
other bytecode (e.g., in a user-specific collection). @defaults[@scheme[#f]]}
@defboolparam[call-install on?]{
If on, call collection @filepath{info.ss}-specified setup code.
@defaults[@scheme[#t]]}
@ -480,6 +484,11 @@ form.}
by the archives are set-up in addition to the collections listed in
specific-collections. @defaults[@scheme[null]]}
@defboolparam[archive-implies-reindex on?]{
If on, when @scheme[archives] has a non-empty list of packages, if any
documentation is built, then suitable documentation start pages, search pages,
and master index pages are re-built. @defaults[@scheme[#t]]}
@defparam[current-target-directory-getter thunk (-> . path-string?)]{
A thunk that returns the target directory for unpacking a relative
@filepath{.plt} archive; when unpacking an archive, either this or
@ -694,7 +703,7 @@ for making @filepath{.plt} archives:}
The @schememodname[setup/plt-single-installer] module provides a
function for installing a single @filepath{.plt} file, and
@schememodname[setup/plt-single-installer] wraps it with a GUI
@schememodname[setup/plt-installer] wraps it with a GUI
interface.
@subsubsection{Non-GUI Installer}
@ -717,7 +726,37 @@ interface.
The @scheme[get-dir-proc] procedure is called if the installer needs a
target directory for installation, and a @scheme[#f] result means that
the user canceled the installation. Typically, @scheme[get-dir-proc] is
@scheme[current-directory].}}
@scheme[current-directory].}
@defproc[(install-planet-package [file path-string?]
[directory path-string?]
[spec (list/c string? string?
(listof string?)
exact-nonnegative-integer?
exact-nonnegative-integer?)])
void?]{
Similar to @scheme[run-single-installer], but runs the setup process
to install the archive @scheme[file] into @scheme[directory] as the
@|PLaneT| package described by @scheme[spec]. The user-specific
documentation index is not rebuilt, so @scheme[reindex-user-documentation]
should be run after a set of @|PLaneT| packages are installed.}
@defproc[(reindex-user-documentation) void?]{
Similar to @scheme[run-single-installer], but runs only the part of
the setup process that rebuilds the user-specific documentation
start page, search page, and master index.}
@defproc[(clean-planet-package [directory path-string?]
[spec (list/c string? string?
(listof string?)
exact-nonnegative-integer?
exact-nonnegative-integer?)])
void?]{
Undoes the work of @scheme[install-planet-package]. The user-specific
documentation index is not rebuilt, so @scheme[reindex-user-documentation]
should be run after a set of @|PLaneT| packages are removed.}}
@subsubsection[#:tag "gui-unpacking"]{GUI Installer}
@ -754,7 +793,8 @@ interface.
@defproc[(run-single-installer (file path-string?)
(get-dir-proc (-> (or/c path-string? false/c))))
void?]{
The same as the sole export of @schememodname[setup/plt-single-installer], but with a GUI.}
The same as the export from @schememodname[setup/plt-single-installer],
but with a GUI.}
@; ----------------------------------------

2
collects/setup/option-sig.ss
View File

@ -16,6 +16,7 @@
make-docs
make-user
make-planet
avoid-main-installation
call-install
call-post-install
pause-on-errors
@ -24,5 +25,6 @@
specific-collections
specific-planet-dirs
archives
archive-implies-reindex
current-target-directory-getter
current-target-plt-directory-getter)))

2
collects/setup/option-unit.ss
View File

@ -34,6 +34,7 @@
(define-flag-param make-docs #t)
(define-flag-param make-user #t)
(define-flag-param make-planet #t)
(define-flag-param avoid-main-installation #f)
(define-flag-param call-install #t)
(define-flag-param call-post-install #t)
(define-flag-param pause-on-errors #f)
@ -44,6 +45,7 @@
(define specific-planet-dirs (make-parameter null))
(define archives (make-parameter null))
(define archive-implies-reindex (make-parameter #t))
(define current-target-directory-getter (make-parameter current-directory))
(define current-target-plt-directory-getter

29
collects/setup/plt-single-installer.ss
View File

@ -14,27 +14,32 @@
compiler/option-unit
compiler/compiler-unit)
(provide run-single-installer install-planet-package clean-planet-package)
(provide run-single-installer install-planet-package clean-planet-package reindex-user-documentation)
;; run-single-installer : string (-> string) -> void
;; runs the instealler on the given package
(define (run-single-installer file get-target-dir)
(run-single-installer/internal file get-target-dir #f #f))
(run-single-installer/internal file get-target-dir #f #f #f))
;; install-planet-package : path path (list string string (listof string) nat nat) -> void
;; unpacks and installs the given planet package into the given path
(define (install-planet-package file directory spec)
(run-single-installer/internal file (lambda () directory) (cons directory spec) #f))
(run-single-installer/internal file (lambda () directory) (cons directory spec) #f #f))
;; clean-planet-package : path (list string string (listof string) nat nat) -> void
;; cleans the given planet package
(define (clean-planet-package directory spec)
(run-single-installer/internal #f (lambda () directory) (cons directory spec) #t))
(run-single-installer/internal #f (lambda () directory) (cons directory spec) #f #t))
;; reindex-user-documentation
;; call after installing or uninstalling a set of Planet packages
(define (reindex-user-documentation)
(run-single-installer/internal #f current-directory #f '(("scribblings/main/user")) #f))
;; run-single-installer : string (-> string) (list path string string nat nat) -> void
;; creates a separate thread, runs the installer in that thread,
;; returns when the thread completes
(define (run-single-installer/internal file get-target-dir planet-spec clean?)
(define (run-single-installer/internal file get-target-dir planet-spec collections clean?)
(let ([cust (make-custodian)])
(parameterize ([current-custodian cust]
[current-namespace (make-namespace)]
@ -47,8 +52,10 @@
(export)
;; >>>>>>>>>>>>>> <<<<<<<<<<<<<<<
;; Here's where we tell setup the archive file!
(unless clean?
(archives (list file)))
(unless (or clean? (not file))
(archives (list file))
(when planet-spec
(archive-implies-reindex #f)))
;; Here's where we make get a directory:
(current-target-directory-getter
@ -56,13 +63,17 @@
(when planet-spec
(specific-planet-dirs (list planet-spec)))
(when collections
(specific-collections collections))
(when clean?
(clean #t)
(make-zo #f)
(make-launchers #f)
(make-info-domain #t)
(call-install #f)))
(call-install #f)
(make-docs #f)))
(invoke-unit
(compound-unit/infer
(import)

2
collects/setup/setup-cmdline.ss
View File

@ -50,6 +50,8 @@
(add-flags '((make-user #f) (make-planet #f)))]
[("--no-planet") "Do not setup PLaneT packages"
(add-flags '((make-planet #f)))]
[("--avoid-main") "Do not make main-installation files"
(add-flags '((avoid-main-installation #t)))]
[("-v" "--verbose") "See names of compiled files and info printfs"
(add-flags '((verbose #t)))]
[("-m" "--make-verbose") "See make and compiler usual messages"

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

@ -646,6 +646,10 @@
;; Make zo ;;
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define compile-skip-directory
(and (avoid-main-installation)
(find-collects-dir)))
(when (make-zo)
(setup-printf #f "--- compiling collections ---")
(with-specified-mode
@ -667,7 +671,7 @@
(setup-fprintf (current-error-port) #f " deleting ~a" (build-path c p))
(delete-file (build-path c p))))))))
;; Make .zos
(compile-directory-zos dir info))
(compile-directory-zos dir info #:skip-path compile-skip-directory))
make-base-empty-namespace))))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -797,7 +801,8 @@
(with-handlers ([exn:fail?
(lambda (exn)
(setup-printf #f "docs failure: ~a" (exn->string exn)))])
(doc:setup-scribblings #f (not (null? (archives))))))
(doc:setup-scribblings #f (and (not (null? (archives)))
(archive-implies-reindex)))))
(when (doc-pdf-dest)
(setup-printf #f "building PDF documentation (via pdflatex)")