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

svn: r15246

collects/compiler/cm.ss

@@ -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))

collects/compiler/compiler-unit.ss

@@ -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)
 

collects/planet/resolver.ss

@@ -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)))))

collects/planet/util.ss

@@ -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

collects/scribble/html-render.ss

@@ -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,6 +614,7 @@
           (call-with-input-file* prefix-file
             (lambda (in)
               (copy-port in (current-output-port))))
+          (parameterize ([xml:empty-tag-shorthand xml:html-empty-tags])
             (xml:write-xml/content
              (xml:xexpr->xml
               `(html ()
@@ -643,7 +642,7 @@
                            (render-version d ri))
                        ,@(navigation d ri #t)
                        ,@(render-part d ri)
-                     ,@(navigation d ri #f))))))))))
+                       ,@(navigation d ri #f)))))))))))
 
     (define/private (part-parent d ri)
       (collected-info-parent (part-collected-info d ri)))

collects/scribblings/main/info.ss

@@ -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))

collects/scribblings/main/user/info.ss

@@ -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))))

collects/scribblings/mzc/make.scrbl

@@ -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
+A parameter whose value is called for each file that is loaded and
-   has already been loaded in the filesystem and, if it has, it
+ needs recompilation. If the procedure returns a number, then the file
-   returns the timestamp of the .zo file for that file (or the .ss file
+ is skipped (i.e., not compiled), and the number is used as the
-   if the .zo file does not exist).}
+ timestamp for the file's bytecode. If the procedure returns
-
+ @scheme[#f], then the file is compiled as usual. The default is
-  Defaults to @scheme[(λ (x) #f)].
+ @scheme[(lambda (x) #f)].}
-}
-}
 
 @; ----------------------------------------------------------------------
 

collects/scribblings/setup-plt/setup-plt.scrbl

@@ -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.}
 
 @; ----------------------------------------
 

collects/setup/option-sig.ss

@@ -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)))

collects/setup/option-unit.ss

@@ -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 

collects/setup/plt-single-installer.ss

@@ -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? 
+                    (unless (or clean? (not file))
-                      (archives (list file)))
+                      (archives (list file))
+                      (when planet-spec
+                        (archive-implies-reindex #f)))
                     
                     ;; Here's where we make get a directory:
                     (current-target-directory-getter
@@ -57,12 +64,16 @@
                     (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)

collects/setup/setup-cmdline.ss

@@ -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"

collects/setup/setup-unit.ss

@@ -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)")