raco pkg create: support "source" and "binary" bundling

Adds `--from-dir' and `--from-install' flags to select the interpretation
of the argument as a directory or as the name of an installed package.
Relevant to PR 13669

Adds `--as-is' (the default), `--source', and `--binary' flags to
select a pruning mode.

The `raco setup' tool recognizes a `rendered-scribblings' specification
in "info.rkt" to trigger moving rendered documentation into place,
registering its tags in the cross-reference database, and fixing up
references to "local-redirect.js"; the presence of a "synced.rktd"
indicates when those fixups have been performed (since, if the package
is installed in a user-specific scope, the documentation doesn't actually
move anywhere). Finally, "out<n>.sxref" needs to report paths relative to
the documentation's directory, and then the relative-directory references
need to be suitably resolved at derserialization; some support for such
relative paths was in place, but it wasn't quite general enough before.

collects/pkg/lib.rkt

@@ -27,6 +27,7 @@
          syntax/modcollapse
          "name.rkt"
          "util.rkt"
+         "strip.rkt"
          (prefix-in db: "db.rkt"))
 
 (define current-pkg-scope
@@ -164,7 +165,7 @@
   (equal? (if (path? a) a (string->path a))
           (if (path? b) b (string->path b))))
 
-(define (check-dependencies deps)
+(define ((check-dependencies which) deps)
   (unless (and (list? deps)
                (for/and ([dep (in-list deps)])
                  (define (package-source? dep)
@@ -199,10 +200,19 @@
                                 [else #f])
                                (loop (hash-set saw (car dep) #t)
                                      (cddr dep)))]))))))
-    (pkg-error (~a "invalid `deps' specification\n"
+    (pkg-error (~a "invalid `" which "' specification\n"
                    "  specification: ~e")
                deps)))
 
+(define (get-all-deps metadata-ns pkg-dir)
+  (append
+   (get-metadata metadata-ns pkg-dir 
+                 'deps (lambda () empty)
+                 #:checker (check-dependencies 'deps))
+   (get-metadata metadata-ns pkg-dir 
+                 'build-deps (lambda () empty)
+                 #:checker (check-dependencies 'build-deps))))
+
 (define (dependency->name dep)
   (package-source->name
    (dependency->source dep)))
@@ -1024,9 +1034,7 @@
       [(and
         (not (eq? dep-behavior 'force))
         (let ()
-          (define deps (get-metadata metadata-ns pkg-dir 
+          (define deps (get-all-deps metadata-ns pkg-dir ))
-                                     'deps (lambda () empty)
-                                     #:checker check-dependencies))
           (define unsatisfied-deps
             (map dependency->source
                  (filter-not (λ (dep)
@@ -1082,9 +1090,7 @@
       [(and
         (not (eq? dep-behavior 'force))
         (let ()
-          (define deps (get-metadata metadata-ns pkg-dir 
+          (define deps (get-all-deps metadata-ns pkg-dir))
-                                     'deps (lambda () empty)
-                                     #:checker check-dependencies))
           (define update-deps
             (filter-map (λ (dep)
                           (define name (dependency->name dep))
@@ -1304,9 +1310,7 @@
           (pkg-desc orig-pkg-source #f pkg-name auto?))]))
 
 (define ((package-dependencies metadata-ns) pkg-name)  
-  (get-metadata metadata-ns (pkg-directory* pkg-name) 
+  (get-all-deps metadata-ns (pkg-directory* pkg-name)))
-                'deps (lambda () empty)
-                #:checker check-dependencies))
 
 (define (pkg-update in-pkgs
                     #:all? [all? #f]
@@ -1420,38 +1424,41 @@
        [_
         (pkg-error "multiple config keys provided")])]))
 
-(define (pkg-create create:format maybe-dir
+(define (create-as-is create:format pkg-name dir orig-dir
-                    #:quiet? [quiet? #f])
+                      #:quiet? [quiet? #f]
+                      #:hide-src? [hide-src? #f]
+                      #:dest [dest-dir #f])
   (begin
-    (define dir (regexp-replace* #rx"/$" maybe-dir ""))
     (unless (directory-exists? dir)
       (pkg-error "directory does not exist\n  path: ~a" dir))
     (match create:format
       ['MANIFEST
        (unless quiet?
          (printf "creating manifest for ~a\n"
-                 dir))
+                 orig-dir))
-       (with-output-to-file
+       (with-output-to-file (build-path (or dest-dir dir) "MANIFEST")
-           (build-path dir "MANIFEST")
          #:exists 'replace
          (λ ()
            (for ([f (in-list (parameterize ([current-directory dir])
                                (find-files file-exists?)))])
              (display f)
              (newline))))]
-      [else      
+      [else
-       (define pkg (format "~a.~a" dir create:format))
+       (define pkg (format "~a.~a" pkg-name create:format))
+       (define actual-dest-dir (or dest-dir 
+                                   (let-values ([(base name dir?) (split-path dir)])
+                                     (cond
+                                      [(path? base) (path->complete-path base)]
+                                      [else (current-directory)]))))
+       (define pkg/complete (path->complete-path pkg actual-dest-dir))
        (unless quiet?
-         (printf "packing ~a into ~a\n"
+         (printf "packing~a into ~a\n"
-                 dir pkg))
+                 (if hide-src? "" (format " ~a" dir))
-       (define pkg-name
+                 (if dest-dir
-         (regexp-replace
+                     pkg/complete
-          (regexp (format "~a$" (regexp-quote (format ".~a" create:format))))
+                     pkg)))
-          (path->string (file-name-from-path pkg))
-          ""))
        (match create:format
          ['tgz
-          (define pkg/complete (path->complete-path pkg))
           (when (file-exists? pkg/complete)
             (delete-file pkg/complete))
           (parameterize ([current-directory dir])
@@ -1461,7 +1468,6 @@
                                     (raise exn))])
               (apply tar-gzip pkg/complete (directory-list))))]
          ['zip
-          (define pkg/complete (path->complete-path pkg))
           (when (file-exists? pkg/complete)
             (delete-file pkg/complete))
           (parameterize ([current-directory dir])
@@ -1471,7 +1477,7 @@
                                     (raise exn))])
               (apply zip pkg/complete (directory-list))))]
          ['plt
-          (define dest (path->complete-path pkg))
+          (define dest pkg/complete)
           (parameterize ([current-directory dir])
             (define names (filter std-filter (directory-list)))
             (define dirs (filter directory-exists? names))
@@ -1483,12 +1489,71 @@
          [x
           (pkg-error "invalid package format\n  format: ~a" x)])
        (define chk (format "~a.CHECKSUM" pkg))
+       (define chk/complete (path->complete-path chk actual-dest-dir))
        (unless quiet?
          (printf "writing package checksum to ~a\n"
-                 chk))
+                 (if dest-dir
-       (with-output-to-file chk
+                     chk/complete
+                     chk)))
+       (with-output-to-file chk/complete
          #:exists 'replace
-         (λ () (display (call-with-input-file pkg sha1))))])))
+         (λ () (display (call-with-input-file pkg/complete sha1))))])))
+
+(define (stripped-create mode name dir
+                        #:format [create:format 'zip]
+                        #:quiet? [quiet? #f]
+                        #:dest [archive-dest-dir #f])
+  (define tmp-dir (make-temporary-file "create-binary-~a" 'directory))
+  (dynamic-wind
+      void
+      (lambda ()
+        (define dest-dir (build-path tmp-dir name))
+        (make-directory dest-dir)
+        (generate-stripped-directory (eq? mode 'binary) dir dest-dir)
+        (create-as-is create:format name dest-dir dir 
+                      #:hide-src? #t 
+                      #:quiet? quiet?
+                      #:dest archive-dest-dir))
+      (lambda ()
+        (delete-directory/files tmp-dir))))
+
+(define (pkg-create create:format dir-or-name
+                    #:dest [dest-dir #f]
+                    #:source [source 'dir]
+                    #:mode [mode 'as-is]
+                    #:quiet? [quiet? #f])
+  (define pkg-name
+    (if (eq? source 'dir)
+        (path->string (let-values ([(base name dir?) (split-path dir-or-name)])
+                        name))
+        dir-or-name))
+  (define dir
+    (if (eq? source 'dir)
+        dir-or-name
+        (let ()
+          (define (get-dir scope)
+            (parameterize ([current-pkg-scope scope])
+              (with-pkg-lock/read-only
+               (pkg-directory* dir-or-name))))
+          (define dir (or (get-dir 'user)
+                          (get-dir 'shared)))
+          (unless dir
+            (pkg-error (~a "package not installed in user or shared scope\n"
+                           "  package name: ~a"
+                           (if (get-dir 'installation)
+                               "\n  installed in scope: installation"
+                               ""))
+                       dir-or-name))
+          dir)))
+  (case mode
+    [(as-is) (create-as-is create:format pkg-name dir dir
+                           #:dest dest-dir
+                           #:quiet? quiet?)]
+    [(source binary) (stripped-create mode pkg-name dir
+                                      #:dest dest-dir
+                                      #:format create:format
+                                      #:quiet? quiet?)]))
+  
 
 (define (pkg-catalog-copy srcs dest
                         #:from-config? [from-config? #f]
@@ -1683,7 +1748,7 @@
           (display mod-str)
           (+ new-col (string-length mod-str)))
         (newline)))]))
-
+  
 (define (get-all-pkg-names-from-catalogs)
   (define ht
     (for*/hash ([i (in-list (pkg-catalogs))]
@@ -1768,8 +1833,12 @@
   (define v (if get-info
                 (get-info 'deps (lambda () empty))
                 empty))
-  (check-dependencies v)
+  ((check-dependencies 'deps) v)
-  v)
+  (define v2 (if get-info
+                (get-info 'build-deps (lambda () empty))
+                empty))
+  ((check-dependencies 'build-deps) v2)
+  (append v v2))
 
 (define (get-pkg-content desc 
                          #:extract-info [extract-info extract-dependencies])
@@ -1942,7 +2011,10 @@
   [pkg-create
    (->* ((or/c 'zip 'tgz 'plt 'MANIFEST)
          path-string?)
-        (#:quiet? boolean?)
+        (#:source (or/c 'dir 'name)
+                  #:mode (or/c 'as-is 'source 'binary)
+                  #:quiet? boolean?
+                  #:dest (or/c (and/c path-string? complete-path?) #f))
         void?)]
   [pkg-update
    (->* ((listof string?))

collects/pkg/main.rkt

@@ -191,8 +191,37 @@
                      [current-pkg-scope-version (or version (r:version))])
         (with-pkg-lock/read-only
          (pkg-show (if only-mode "" " ") #:directory? dir)))))]
+ [create
+  "Bundle a package from a directory or installed package"
+  #:once-any
+  [#:bool from-dir () "Treat <directory-or-package> as a directory (the default)"]
+  [#:bool from-install () "Treat <directory-or-package> as a package name"]
+  #:once-any
+  [(#:sym fmt [zip tgz plt] #f) format ()
+   ("Select the format of the package to be created;"
+    "valid <fmt>s are: zip (the default), tgz, plt")]
+  [#:bool manifest () "Creates a manifest file for a directory, rather than an archive"]
+  #:once-any
+  [#:bool as-is () "Bundle the directory/package as-is (the default)"]
+  [#:bool source () "Bundle sources only"]
+  [#:bool binary () "Bundle bytecode and rendered documentation without sources"]
+  #:once-each
+  [(#:str dest-dir #f) dest () "Create output files in <dest-dir>"]
+  #:args (directory-or-package)
+  (parameterize ([current-pkg-error (pkg-error 'create)])
+    (pkg-create (if manifest 'MANIFEST (or format 'zip)) 
+                directory-or-package
+                #:dest (and dest 
+                            (path->complete-path dest))
+                #:source (cond
+                          [from-install 'name]
+                          [else 'dir])
+                #:mode (cond
+                        [source 'source]
+                        [binary 'binary]
+                        [else 'as-is])))]
  [config
-  "View and modify the package configuration"
+  "View and modify the package manager's configuration"
   #:once-each
   [#:bool set () "Completely replace the value"]
   #:once-any
@@ -214,16 +243,6 @@
           (pkg-config #t key/val))
          (with-pkg-lock/read-only
           (pkg-config #f key/val)))))]
- [create
-  "Bundle a new package"
-  #:once-any
-  [(#:sym fmt [zip tgz plt] #f) format ()
-   ("Select the format of the package to be created;"
-    "valid <fmt>s are: zip (the default), tgz, plt")]
-  [#:bool manifest () "Creates a manifest file for a directory, rather than an archive"]
-  #:args (package-directory)
-  (parameterize ([current-pkg-error (pkg-error 'create)])
-    (pkg-create (if manifest 'MANIFEST (or format 'zip)) package-directory))]
  [catalog-show
   "Show information about packages as reported by catalog"
   #:once-any 

collects/pkg/scribblings/pkg.scrbl

@@ -297,8 +297,9 @@ sub-sub-commands:
 installed (e.g. it conflicts with another installed package), then
 this command fails without installing any of the @nonterm{pkg}s 
 (or their dependencies).
-The @exec{update} sub-command accepts 
+
-the following @nonterm{option}s:
+ The @exec{update} sub-command accepts 
+ the following @nonterm{option}s:
 
  @itemlist[
  @item{@DFlag{deps} @nonterm{behavior} --- Same as for @command-ref{install}.}
@@ -315,7 +316,10 @@ the following @nonterm{option}s:
 @item{@command/toc{remove} @nonterm{option} ... @nonterm{pkg} ... 
 --- Attempts to remove the given packages. If a package is the dependency
 of another package that is not listed, this command fails without 
-removing any of the @nonterm{pkg}s. This command accepts the following @nonterm{option}s:
+removing any of the @nonterm{pkg}s.
+
+ The @exec{remove} sub-command accepts 
+ the following @nonterm{option}s:
 
  @itemlist[
  @item{@DFlag{force} --- Ignore dependencies when removing packages.}
@@ -332,7 +336,9 @@ removing any of the @nonterm{pkg}s. This command accepts the following @nonterm{
 @item{@command/toc{show} @nonterm{option} ... --- Print information about currently installed packages. 
  By default, packages are shown for all installation modes (installation-wide,
  user- and Racket-version-specific, and user-specific all-version).
- The command accepts the following @nonterm{option}s:
+
+ The @exec{show} sub-command accepts 
+ the following @nonterm{option}s:
 
  @itemlist[
 
@@ -352,8 +358,60 @@ removing any of the @nonterm{pkg}s. This command accepts the following @nonterm{
  ]
 }
 
+@item{@command/toc{create} @nonterm{option} ... @nonterm{directory-or-package}
+--- Bundles a package into an archive. Bundling
+    is not needed for a package that is provided directly from a
+    GitHub repository or other non-archive formats. The @exec{create}
+    sub-command can create an archive from a directory (the default) or
+    from an installed package. It can also adjust the archive's content
+    to include only sources (which is the recommended mode, although not
+    the default) or as a ``binary'' package (but packages are
+    normally provided as source and converted to binary form by an
+    automatic service, instead of by a package author).
+
+ The @exec{create} sub-command accepts 
+ the following @nonterm{option}s:
+
+ @itemlist[
+ @item{@DFlag{from-dir} --- Treat @nonterm{directory-or-package} as a directory path; this is the default mode.}
+ @item{@DFlag{from-install} --- Treat @nonterm{directory-or-package} as the name of an installed package 
+       (instead of a directory).}
+ @item{@DFlag{format} @nonterm{format} --- Specifies the archive format. 
+      The allowed @nonterm{format}s are: @exec{zip} (the default), @exec{tgz}, and @exec{plt}. 
+      This option must be specified if @DFlag{manifest} is not present.}
+ @item{@DFlag{manifest} --- Creates a manifest file for a directory, rather than an archive.}
+ @item{@DFlag{as-is} --- Bundle all content of the package directory as is, with no filtering
+       of sources, compiled files, or repository elements.}
+ @item{@DFlag{source} --- Bundle only sources in the package directory, pruning (by default) 
+       @filepath{compiled} directories (that normally hold compiled
+       bytecode), @filepath{doc} directories (that normally hold rendered documentation),
+       directories named @filepath{.svn}, and directories and files whose names start with @filepath{.git}.
+       Override the default pruning rules with @racket[source-omit-files] and/or
+       @racket[source-keep-files] definitions in @filepath{info.rkt} files within the
+       package directory.}
+ @item{@DFlag{binary} --- Bundle compiled bytecode and rendered
+       documentation in the package directory. Normally, this option is sensible for
+       a package that is installed from source in a user-specific scope. Bundling prunes (by default)
+       @filepath{.rkt} and @filepath{.ss} files for which compiled bytecode is present, files with
+       a @filepath{.scrbl} suffix, @filepath{tests} directories, @filepath{scribblings}
+       directories, @filepath{.svn} directories, and directories and files whose names 
+       start with @filepath{.git}. For each @filepath{.html} file that
+       refers to a @filepath{local-redirect.js} script, the path to the script is removed.
+       In addition, bundling updates any @filepath{info.rkt} as follows: it
+       adds a @racket[assume-virtual-sources] entry,
+       converts a @racket[scribblings] entry to a @racket[rendered-scribblings] entry,
+       changes a @racket[copy-foreign-libs] entry to a @racket[move-foreign-libs] entry,
+       changes a @racket[copy-man-pages] entry to a @racket[move-man-pages] entry,
+       and removes any @racket[build-deps] entry. Override
+       the default pruning rules with @racket[binary-omit-files]
+       and/or @racket[binary-keep-files] definitions in
+       @filepath{info.rkt} files within the package directory.}
+  @item{@DFlag{dest} @nonterm{dest-dir} --- Writes generated bundles to @nonterm{dest-dir}.}
+  ]
+}
+
 @item{@command/toc{config} @nonterm{option} ... @nonterm{key} @nonterm{val} ... --- 
-View and modify package configuration options. This command accepts the following @nonterm{option}s:
+View and modify configuration of the package manager itself, with the following @nonterm{option}s:
 
  @itemlist[
  @item{@DFlag{set} --- Sets an option, rather than printing it.}
@@ -372,21 +430,13 @@ View and modify package configuration options. This command accepts the followin
  ]
 }
 
-@item{@command/toc{create} @nonterm{option} ... @nonterm{package-directory}
---- Bundles a package directory into a package archive. This command accepts the following @nonterm{option}s:
-
- @itemlist[
- @item{@DFlag{format} @nonterm{format} --- Specifies the archive format. 
-      The allowed @nonterm{format}s are: @exec{zip} (the default), @exec{tgz}, and @exec{plt}. 
-      This option must be specified if @DFlag{manifest} is not present.}
- @item{@DFlag{manifest} --- Creates a manifest file for a directory, rather than an archive.}
- ]
-}
-
 @item{@command/toc{catalog-show} @nonterm{option} ... @nonterm{package-name} ...
 --- Consults @tech{package catalogs} for a package (that is not necessarily installed)
     and displays the catalog's information for the package, such as its source URL and
-    a checksum. This command accepts the following @nonterm{option}s:
+    a checksum.
+
+ The @exec{catalog-show} sub-command accepts 
+ the following @nonterm{option}s:
 
  @itemlist[
  @item{@DFlag{all} --- Show information for all available packages. When using this flag,
@@ -412,7 +462,8 @@ View and modify package configuration options. This command accepts the followin
     with information from earlier @nonterm{src-catalog}s taking precedence over later 
     @nonterm{src-catalog}s.
 
-    This command accepts the following @nonterm{option}s:
+    The @exec{catalog-copy} sub-command accepts 
+    the following @nonterm{option}s:
 
  @itemlist[
  @item{@DFlag{from-config} --- Adds the currently configured 
@@ -695,6 +746,13 @@ The following @filepath{info.rkt} fields are used by the package manager:
        Use the package name @racket["racket"] to specify a dependency
        on the version of the Racket installation.}
 
+ @item{@racketidfont{build-deps} --- like @racketidfont{deps}, but for
+       dependencies that can be dropped in a ``binary'' variant of the
+       package that does not include sources. The
+       @racketidfont{build-deps} and @racketidfont{deps} lists are appended,
+       while @command-ref["create"] strips away @racketidfont{build-deps}
+       when converting a package for @DFlag{binary} mode.}
+
  @item{@racketidfont{setup-collects} --- a list of path strings and/or
        lists of path strings, which are used as collection names to
        set up via @exec{raco setup} after the package is installed, or

collects/pkg/strip.rkt

@@ -0,0 +1,171 @@
+#lang racket/base
+(require compiler/cm
+         setup/getinfo
+         syntax/modread
+         racket/match
+         racket/file)
+
+(provide generate-stripped-directory
+         fixup-local-redirect-reference)
+
+(define (generate-stripped-directory binary? dir dest-dir)
+  (define drop-keep-ns (make-base-namespace))
+  (define (add-drop+keeps dir base drops keeps)
+    (define get-info (get-info/full dir #:namespace drop-keep-ns))
+    (define drop-tag (if binary? 'binary-omit-files 'source-omit-files))
+    (define more-drops (if get-info
+                           (get-info drop-tag (lambda () null))
+                           null))
+    (define keep-tag (if binary? 'binary-keep-files 'source-keep-files))
+    (define more-keeps (if get-info
+                           (get-info keep-tag (lambda () null))
+                           null))
+    (define (check tag l)
+      (unless (and (list? l) (andmap (lambda (p)
+                                       (and (path-string? p)
+                                            (relative-path? p)))
+                                     l))
+        (error 'strip "bad ~a value from \"info.rkt\": ~e" tag l)))
+    (check drop-tag more-drops)
+    (check keep-tag more-keeps)
+
+    (define (add ht l)
+      (for/fold ([ht ht]) ([i (in-list l)])
+        (hash-set ht 
+                  (if (eq? base 'same)
+                      (if (path? i) i (string->path i))
+                      (build-path base i))
+                  #t)))
+    (values (add drops more-drops)
+            (add keeps more-keeps)))
+  
+  (define (drop-by-default? path get-p)
+    (define bstr (path->bytes path))
+    (or (regexp-match? #rx#"^(?:[.]git.*|[.]svn)$"
+                       bstr)
+        (regexp-match? (if binary?
+                           #rx#"^(?:[.]git.*|[.]svn|tests|scribblings|.*[.]scrbl)$"
+                           #rx#"^(?:compiled|doc)$")
+                       bstr)
+        (and binary?
+             (regexp-match? #rx"[.](?:ss|rkt)$" bstr)
+             (not (equal? #"info.rkt" bstr))
+             (file-exists? (let-values ([(base name dir?) (split-path (get-p))])
+                             (build-path base "compiled" (path-add-suffix name #".zo")))))
+        (and binary?
+             (or (equal? #"info_rkt.zo" bstr)
+                 (equal? #"info_rkt.dep" bstr)))))
+
+  (define (fixup new-p path)
+    (when binary?
+      (define bstr (path->bytes path))
+      (cond
+       [(regexp-match? #rx"[.]html$" bstr)
+        (fixup-html new-p)]
+       [(equal? #"info.rkt" bstr)
+        (fixup-info new-p)]
+       [else (void)])))
+  
+  (define (explore base paths drops keeps)
+    (for ([path (in-list paths)])
+      (define p (if (eq? base 'same)
+                    path
+                    (build-path base path)))
+      (when (and (not (hash-ref drops p #f))
+                 (or (hash-ref keeps p #f)
+                     (not (drop-by-default? 
+                           path
+                           (lambda () (build-path dir p))))))
+        (define old-p (build-path dir p))
+        (define new-p (build-path dest-dir p))
+        (cond
+         [(file-exists? old-p)
+          (copy-file old-p new-p)
+          (fixup new-p path)]
+         [(directory-exists? old-p)
+          (define-values (new-drops new-keeps)
+            (add-drop+keeps old-p p drops keeps))
+          (make-directory new-p)
+          (explore p
+                   (directory-list old-p)
+                   new-drops
+                   new-keeps)]
+         [else (error 'strip "file or directory disappeared?")]))))
+
+  (define-values (drops keeps)
+    (add-drop+keeps dir 'same #hash() #hash()))
+  
+  (explore 'same (directory-list dir) drops keeps))
+
+(define (fixup-html new-p)
+  ;; strip full path to "local-redirect.js"
+  (fixup-local-redirect-reference new-p ".."))
+
+(define (fixup-local-redirect-reference p js-path)
+  ;; Relying on this HTML pattern (as generated by Scribble's HTML
+  ;; renderer) is a little fragile. Any better idea?
+  (define rx #rx"<script type=\"text/javascript\" src=\"([^\"]*)/local-redirect.js\">")
+  (define m (call-with-input-file*
+             p
+             (lambda (i) (regexp-match-positions rx i))))
+  (when m
+    (define start (caadr m))
+    (define end (cdadr m))
+    (define bstr (file->bytes p))
+    (define new-bstr
+      (bytes-append (subbytes bstr 0 start)
+                    (string->bytes/utf-8 js-path)
+                    (subbytes bstr end)))
+    (call-with-output-file* 
+     p
+     #:exists 'truncate/replace
+     (lambda (out) (write-bytes new-bstr out)))))
+
+(define (fixup-info new-p)
+  (define dir (let-values ([(base name dir?) (split-path new-p)])
+                base))
+  ;; check format:
+  (define get-info
+    (get-info/full dir #:namespace (make-base-namespace)))
+  (when get-info
+    ;; read in:
+    (define content
+      (call-with-input-file* 
+       new-p
+       (lambda (in)
+         (begin0 
+          (with-module-reading-parameterization
+           (lambda () (read in)))))))
+    ;; convert:
+    (define new-content
+      (match content
+        [`(module info setup/infotab (#%module-begin . ,defns))
+         `(module info setup/infotab
+            (#%module-begin
+             (define assume-virtual-sources '())
+             . ,(filter values
+                        (map (fixup-info-definition get-info) defns))))]))
+    ;; write updated:
+    (call-with-output-file* 
+     new-p
+     #:exists 'truncate
+     (lambda (out)
+       (write new-content out)
+       (newline out)))
+    ;; sanity check:
+    (unless (get-info/full dir #:namespace (make-base-namespace))
+      (error 'pkg-binary-create "rewrite failed"))
+    ;; compile it:
+    (managed-compile-zo new-p)))
+
+
+(define ((fixup-info-definition get-info) defn)
+  (match defn
+    [`(define build-deps . ,v) #f]
+    [`(define scribblings . ,v)
+     `(define rendered-scribblings . ,v)]
+    [`(define copy-foreign-libs . ,v)
+     `(define move-foreign-libs . ,v)]
+    [`(define copy-man-pages . ,v)
+     `(define move-man-pages . ,v)]
+    [_ defn]))

collects/scribble/base-render.rkt

@@ -264,7 +264,8 @@
 
     (define/public (root-relative->path p)
       (if (root-relative? p)
-          (apply build-path (mobile-root-path (car p))
+          (apply build-path (or (mobile-root-path (car p))
+                                (current-directory))
                  (map bytes->path-element (cdr p)))
           p))
 
@@ -336,7 +337,13 @@
 
     (define/public (serialize-one-ht ri ht)
       (parameterize ([current-serialize-resolve-info ri])
-        (serialize (cons root ht))))
+        (let ([rp (mobile-root-path root)])
+          (when rp
+            (set-mobile-root-path! root #f))
+          (begin0
+           (serialize (cons root ht))
+           (when rp
+             (set-mobile-root-path! root rp))))))
 
     (define/public (deserialize-info v ci #:root [root-path #f])
       (let ([root+ht (deserialize v)]

collects/scribble/xref.rkt

@@ -15,7 +15,9 @@
          xref-tag->path+anchor
          xref-tag->index-entry
          xref-transfer-info
-         (struct-out entry))
+         (struct-out entry)
+         make-data+root
+         data+root?)
 
 (define-struct entry
   (words    ; list of strings: main term, sub-term, etc.
@@ -23,6 +25,8 @@
    tag      ; for generating a Scribble link
    desc))   ; further info that depends on the kind of index entry
 
+(define-struct data+root (data root))
+
 ;; Private:
 (define-struct xrefs (renderer ri))
 
@@ -44,7 +48,10 @@
                                         (namespace-anchor->empty-namespace here)])
                           (let ([vs (src)])
                             (for ([v (in-list (if (procedure? vs) (vs) (list vs)))])
-                              (when v (send renderer deserialize-info v ci #:root root-path))))))]
+                              (when v
+                                (define data (if (data+root? v) (data+root-data v) v))
+                                (define root (if (data+root? v) (data+root-root v) root-path))
+                                (send renderer deserialize-info data ci #:root root))))))]
          [ci (send renderer collect null null fp
                    (lambda (key ci)
                      (define src (demand-source key))

collects/scribblings/main/private/manuals.rkt

@@ -28,19 +28,19 @@
                                       (truncate (/ (caar l) 10))))])
                     (if sep? (cons (mk-sep lbl) l) l))]))))
 
-(define (make-start-page all?)
+(define (get-docs all? tag)
-  (let* ([recs (find-relevant-directory-records '(scribblings) 'all-available)]
+  (let* ([recs (find-relevant-directory-records (list tag) 'all-available)]
          [infos (map get-info/full (map directory-record-path recs))]
          [main-dirs (parameterize ([current-library-collection-paths
                                     (list (find-collects-dir))])
-                      (for/hash ([k (in-list (find-relevant-directories '(scribblings) 'no-planet))])
+                      (for/hash ([k (in-list (find-relevant-directories (list tag) 'no-planet))])
                         (values k #t)))]
          [docs (append-map
                 (lambda (i rec)
                   (define dir (directory-record-path rec))
                   (define s (and (or all? (hash-ref main-dirs dir #f))
                                  i
-                                 (i 'scribblings)))
+                                 (i tag)))
                   (if (not s)
                     null
                     (filter-map
@@ -83,7 +83,12 @@
                                          (cdr spec))))))))
                      s)))
                 infos
-                recs)]
+                recs)])
+    docs))
+
+(define (make-start-page all?)
+  (let* ([docs (append (get-docs all? 'scribblings)
+                       (get-docs all? 'rendered-scribblings))]
          [docs (cons
                 ;; Add HtDP
                 (list

collects/scribblings/raco/setup.scrbl

@@ -513,6 +513,12 @@ Optional @filepath{info.rkt} fields trigger additional actions by
    case, so it can be provided by the same file that provides the
    previous two.}
 
+ @item{@indexed-racket[assume-virtual-sources] : @racket[any/c] ---
+   A true value indicates that bytecode files without a corresponding
+   source file should not be removed from @filepath{compiled} directories,
+   and no files should not be removed when the
+   @DFlag{clean} or @Flag{c} flag is passed to @exec{raco setup}.}
+
  @item{@indexed-racket[clean] : @racket[(listof path-string?)] ---
    @elemtag["clean"] A list of pathnames to be deleted when the
    @DFlag{clean} or @Flag{c} flag is passed to @exec{raco setup}. The

collects/scribblings/scribble/xref.scrbl

@@ -19,7 +19,7 @@ Returns @racket[#t] if @racket[v] is a cross-reference record created
 by @racket[load-xref], @racket[#f] otherwise.}
 
 
-@defproc[(load-xref [sources (listof (-> any/c))]
+@defproc[(load-xref [sources (listof (-> (or/c any/c (-> list?))))]
                     [#:demand-source demand-source 
                                      (tag? -> (or/c (-> any/c) #f)) 
                                      (lambda (_tag) #f)]
@@ -28,10 +28,19 @@ by @racket[load-xref], @racket[#f] otherwise.}
                     [#:root root-path (or/c path-string? false/c) #f])
          xref?]{
 
-Creates a cross-reference record given a list of functions that each
+Creates a cross-reference record given a list of functions,
-produce a serialized information obtained from @xmethod[render<%>
+@racket[sources]. 
-serialize-info]. If a @racket[sources] element produces @racket[#f],
+
-its result is ignored.
+Let @racket[_source] be a function in @racket[sources]. The
+@racket[_source] function normally returns serialized information,
+@racket[_info], which was formerly obtained from @xmethod[render<%>
+serialize-info]. The result of @racket[_source] can optionally be
+another function, which is in turn responsible for returning a list of
+@racket[_info]s. Finally, each @racket[_info] can be either serialized
+information, a @racket[#f] to be ignored, or a value produced by
+@racket[make-data+root] from which @racket[_data] part is used as
+serialized information and the @racket[_root] part overrides
+@racket[root-path] for deserialization.
 
 The @racket[demand-source] function can effectively add a new source
 to @racket[sources] in response to a search for information on the
@@ -46,7 +55,10 @@ Latex/PDF and text).
 
 If @racket[root-path] is not @racket[#f], then file paths that are
 serialized as relative to an instantiation-supplied @racket[root-path]
-are deserialized as relative instead to the given @racket[root-path].
+are deserialized as relative instead to the given @racket[root-path],
+but a @racket[make-data+root] result for any @racket[_info] supplies
+an alternate path for deserialization of the @racket[_info]'s
+@racket[_data].
 
 Use @racket[load-collections-xref] from @racketmodname[setup/xref] to
 get all cross-reference information for installed documentation.}
@@ -191,3 +203,13 @@ The @racket[words] list corresponds to
 corresponds to @racket[index-element-entry-seq]. The @racket[desc]
 value corresponds to @racket[index-element-desc]. The @racket[tag] is
 the destination for the index link into the main document.}
+
+
+@deftogether[(
+@defproc[(data+root? [v any/c]) boolean?]
+@defproc[(make-data+root [data any/c] [root (or/c #f path-string?)]) data+root?]
+)]{
+
+A value constructed by @racket[make-data+root] can be returned by a
+source procedure for @racket[load-xref] to specify a path used for
+deserialization.}

collects/setup/scribble.rkt

@@ -26,6 +26,7 @@
          unstable/file
          racket/place
          pkg/lib
+         pkg/strip
          (only-in net/url url->string path->url)
          (prefix-in html: scribble/html-render)
          (prefix-in latex: scribble/latex-render)
@@ -39,7 +40,16 @@
 
 (define-logger setup)
 
-(define-serializable-struct doc (src-dir src-spec src-file dest-dir flags under-main? pkg? category out-count)
+(define-serializable-struct doc (src-dir 
+                                 src-spec
+                                 src-file
+                                 dest-dir
+                                 flags
+                                 under-main?
+                                 pkg?
+                                 category
+                                 out-count
+                                 pre-rendered?)
   #:transparent)
 (define-serializable-struct info (doc       ; doc structure above
                                   undef     ; unresolved requires
@@ -137,8 +147,10 @@
                                   (apply validate i)))
                            infos)])
            (and (not (memq #f infos)) infos))))
-  (define ((get-docs main-dirs) i rec)
+  (define ((get-docs main-dirs pre-rendered?) i rec)
-    (let* ([pre-s (and i (i 'scribblings))]
+    (let* ([pre-s (and i (i (if pre-rendered?
+                                'rendered-scribblings
+                                'scribblings)))]
            [s (validate-scribblings-infos pre-s)]
            [dir (directory-record-path rec)])
       (if s
@@ -151,7 +163,8 @@
                               (or (memq 'main-doc flags)
                                   (hash-ref main-dirs dir #f)
                                   (pair? (path->main-collects-relative dir))))])
-                   (define src (doc-path dir (cadddr d) flags under-main?))
+                   (define src (simplify-path (build-path dir (car d)) #f))
+                   (define dest (doc-path dir (cadddr d) flags under-main?))
                    (make-doc dir
                              (let ([spec (directory-record-spec rec)])
                                (list* (car spec)
@@ -161,25 +174,35 @@
                                                         (list (directory-record-maj rec)
                                                               (list '= (directory-record-min rec)))))
                                           (cdr spec))))
-                             (simplify-path (build-path dir (car d)) #f)
                              src
+                             dest
                              flags under-main? (and (path->pkg src) #t)
                              (caddr d)
-                             (list-ref d 4))))
+                             (list-ref d 4)
+                             pre-rendered?)))
                s)
           (begin (setup-printf
                   "WARNING"
-                  "bad 'scribblings info: ~e from: ~e" pre-s dir)
+                  "bad '~ascribblings info: ~e from: ~e" 
+                  (if pre-rendered? "rendered-" "")
+                  pre-s dir)
                  null))))
   (log-setup-info "getting documents")
   (define docs
     (let* ([recs (find-relevant-directory-records '(scribblings) 'all-available)]
+           [r-recs (find-relevant-directory-records '(rendered-scribblings) 'all-available)]
            [main-dirs (parameterize ([current-library-collection-paths
                                       (list (find-collects-dir))])
-                        (for/hash ([k (in-list (find-relevant-directories '(scribblings) 'no-planet))])
+                        (for/hash ([k (in-list
+                                       (append
+                                        (find-relevant-directories '(rendered-scribblings) 'no-planet)
+                                        (find-relevant-directories '(scribblings) 'no-planet)))])
                           (values k #t)))]
-           [infos (map get-info/full (map directory-record-path recs))])
+           [infos (map get-info/full (map directory-record-path recs))]
-      (filter-user-docs (append-map (get-docs main-dirs) infos recs) make-user?)))
+           [r-infos (map get-info/full (map directory-record-path r-recs))])
+      (filter-user-docs (append (append-map (get-docs main-dirs #f) infos recs) 
+                                (append-map (get-docs main-dirs #t) r-infos r-recs))
+                        make-user?)))
   (define-values (main-docs user-docs) (partition doc-under-main? docs))
 
   (when (and (or (not only-dirs) tidy?)
@@ -583,6 +606,7 @@
               (if multi?
                   contract:override-render-mixin-multi 
                   contract:override-render-mixin-single)]
+             [bundleable? (and (not main?) (doc-pkg? doc))]
              [local-redirect-file (build-path (if main?
                                                   (find-doc-dir)
                                                   (find-user-doc-dir))
@@ -613,11 +637,21 @@
                                  (if main?
                                      #t
                                      (build-path (find-user-doc-dir) "index.html")))]
+
+               ;; In cross-reference information, use paths that are relative
+               ;; to the target rendering directory for documentation that might
+               ;; be moved into a binary package:
+               [root-path (and bundleable? ddir)]
+
                [search-box? #t]))
-        (when (and (not main?) (doc-pkg? doc))
+        (when bundleable?
+          ;; For documentation that might be moved into a binary package,
+          ;; use a server indirection for all links external to the
+          ;; document, but also install the "local-redirect.js" hook:
           (send r set-external-tag-path 
                 (format "http://pkg-docs.racket-lang.org?version=~a" (version)))
           (send r add-extra-script-file local-redirect-file))
+        ;; Result is the renderer:
         r)))
 
 (define (pick-dest latex-dest doc)
@@ -724,18 +758,29 @@
                        with-record-error setup-printf workerid 
                        only-fast? force-out-of-date? lock)
          doc)
+
+  ;; First, move pre-rendered documentation into place
+  (when (and (doc-pre-rendered? doc)
+             (can-build? only-dirs doc)
+             (or (not (directory-exists? (doc-dest-dir doc)))
+                 force-out-of-date?
+                 (not (file-exists? (build-path (doc-dest-dir doc) "synced.rktd")))))
+    (move-documentation-into-place doc setup-printf workerid lock))
+
   (let* ([info-out-files (for/list ([i (add1 (doc-out-count doc))])
                            (sxref-path latex-dest doc (format "out~a.sxref" i)))]
          [info-in-file  (sxref-path latex-dest doc "in.sxref")]
          [db-file (find-db-file doc latex-dest)]
          [stamp-file  (sxref-path latex-dest doc "stamp.sxref")]
          [out-file (build-path (doc-dest-dir doc) "index.html")]
-         [src-zo (let-values ([(base name dir?) (split-path (doc-src-file doc))])
+         [src-zo (and 
-                   (define path (build-path base "compiled" (path-add-suffix name ".zo")))
+                  (not (doc-pre-rendered? doc))
-                   (or (for/or ([root (in-list (current-compiled-file-roots))])
+                  (let-values ([(base name dir?) (split-path (doc-src-file doc))])
-                         (define p (reroot-path* path root))
+                    (define path (build-path base "compiled" (path-add-suffix name ".zo")))
-                         (and (file-exists? p) p))
+                    (or (for/or ([root (in-list (current-compiled-file-roots))])
-                       path))]
+                          (define p (reroot-path* path root))
+                          (and (file-exists? p) p))
+                        path)))]
          [renderer (make-renderer latex-dest doc)]
          [can-run? (can-build? only-dirs doc)]
          [stamp-time (file-or-directory-modify-seconds stamp-file #f (lambda () -inf.0))]
@@ -770,22 +815,25 @@
          [info-in-time (file-or-directory-modify-seconds info-in-file #f (lambda () #f))]
          [info-time (min (or info-out-time -inf.0) (or info-in-time -inf.0))]
          [vers (send renderer get-serialize-version)]
-         [src-time (file-or-directory-modify-seconds/stamp
+         [src-time (and (not (doc-pre-rendered? doc))
-                    src-zo
+                        (file-or-directory-modify-seconds/stamp
-                    stamp-time stamp-data 0
+                         src-zo
-                    get-compiled-file-sha1)]
+                         stamp-time stamp-data 0
+                         get-compiled-file-sha1))]
          [up-to-date?
-          (and (not force-out-of-date?)
+          (or (doc-pre-rendered? doc)
-               info-out-time
+              (and (not force-out-of-date?)
-               info-in-time
+                   info-out-time
-               (or (not can-run?)
+                   info-in-time
-                   ;; Need to rebuild if output file is older than input:
+                   (or (not can-run?)
-                   (my-time . >= . src-time)
+                       ;; Need to rebuild if output file is older than input:
-                   ;; But we can use in/out information if they're already built;
+                       (my-time . >= . src-time)
-                   ;; this is mostly useful if we interrupt setup-plt after
+                       ;; But we can use in/out information if they're already built;
-                   ;; it runs some documents without rendering them:
+                       ;; this is mostly useful if we interrupt setup-plt after
-                   (info-time . >= . src-time)))]
+                       ;; it runs some documents without rendering them:
-         [can-run? (and (or (not latex-dest)
+                       (info-time . >= . src-time))))]
+         [can-run? (and (not (doc-pre-rendered? doc))
+                        (or (not latex-dest)
                             (not (omit? (doc-category doc))))
                         (or can-run?
                             (and auto-main?
@@ -907,7 +955,7 @@
 
                      (when (or (stamp-time . < . aux-time)
                                (stamp-time . < . src-time))
-                       (let ([data (list (get-compiled-file-sha1 src-zo)
+                       (let ([data (list (and src-zo (get-compiled-file-sha1 src-zo))
                                          (get-compiled-file-sha1 renderer-path)
                                          (get-file-sha1 css-path))])
                          (with-compile-output stamp-file (lambda (out tmp-filename) (write data out)))
@@ -918,6 +966,56 @@
              (lambda () #f))
             #f))))
 
+(define (move-documentation-into-place doc setup-printf workerid lock)
+  (define src-dir (let-values ([(base name dir?) (split-path (doc-src-file doc))])
+                    (build-path base "doc" (path-replace-suffix name #""))))
+  (define dest-dir (doc-dest-dir doc))
+  (define move? (not (equal? (file-or-directory-identity src-dir)
+                             (and (directory-exists? dest-dir)
+                                  (file-or-directory-identity dest-dir)))))
+  (setup-printf (string-append
+                 (if workerid (format "~a " workerid) "")
+                 (if move? "moving" "syncing"))
+                "~a"
+                (path->relative-string/setup src-dir))
+
+  (when move?
+    (when (directory-exists? dest-dir)
+      (delete-directory/files dest-dir)
+    (copy-directory/files src-dir dest-dir)
+    (delete-directory/files src-dir)))
+  ;; Register provided-tag information with the database:
+  (let ([provides-path (build-path dest-dir "provides.sxref")])
+    (when (file-exists? provides-path)
+      ;; register keys provided in "out<n>.sxref" with
+      ;; the database
+      (define providess (call-with-input-file*
+                         provides-path
+                         (lambda (in) (fasl->s-exp in))))
+      (define db-file (find-db-file doc #f))
+      (for ([provides (in-list providess)]
+            [n (in-naturals)])
+        (define filename (sxref-path #f doc (format "out~a.sxref" n)))
+        (call-with-lock
+         lock
+         (lambda ()
+           (doc-db-clear-provides db-file filename)
+           (doc-db-add-provides db-file provides filename))))))
+  ;; For each ".html" file, check for a reference to "local-redirect.js",
+  ;; and fix up the path if there is a reference:
+  (define js-path (if (doc-under-main? doc)
+                      "../local-redirect"
+                      (url->string (path->url (build-path (find-user-doc-dir)
+                                                          "local-redirect")))))
+  (for ([p (in-directory dest-dir)])
+    (when (regexp-match? #rx#"[.]html$" (path->bytes p))
+      (fixup-local-redirect-reference p js-path)))
+  ;; The existence of "synced.rktd" means that the db is in sync
+  ;; with "provides.sxref" and ".html" files have been updated.
+  (let ([provided-path (build-path dest-dir "synced.rktd")])
+    (unless (file-exists? provided-path)
+      (call-with-output-file provided-path (lambda (o) (write '#t o))))))
+
 (define (read-delayed-in! info latex-dest)
   (let* ([doc (info-doc info)]
          [info-in-file (sxref-path latex-dest doc "in.sxref")]
@@ -1127,7 +1225,15 @@
                lock
                (lambda ()
                  (doc-db-clear-provides db-file filename)
-                 (doc-db-add-provides db-file provides filename)))))))
+                 (doc-db-add-provides db-file provides filename))))))
+  ;; Used for a package is converted to "binary" form:
+  (when (and (doc-pkg? doc)
+             (not (doc-under-main? doc))
+             (not latex-dest))
+    (with-compile-output
+     (sxref-path latex-dest doc "provides.sxref")
+     (lambda (out tmp-filename)
+       (s-exp->fasl providess out)))))
 
 (define (write-out/info latex-dest info scis providess db-file lock)
   (write-out latex-dest (info-vers info) (info-doc info) scis providess db-file lock))

collects/setup/setup-unit.rkt

@@ -597,9 +597,11 @@
          info
          'clean
          (lambda ()
-           (list mode-dir
+           (if (info 'assume-virtual-sources (lambda () #f))
-                 (build-path mode-dir "native")
+               null
-                 (build-path mode-dir "native" (system-library-subpath))))
+               (list mode-dir
+                     (build-path mode-dir "native")
+                     (build-path mode-dir "native" (system-library-subpath)))))
          (lambda (x)
            (unless (list-of path-string? x)
              (error name-sym

collects/setup/xref.rkt

@@ -14,19 +14,19 @@
 
 (define cached-xref #f)
 
-(define (get-dests no-user?)
+(define (get-dests tag no-user?)
   (define main-dirs
     (parameterize ([current-library-collection-paths
                     (let ([d (find-collects-dir)]) 
                       (if d (list d) null))])
-      (for/hash ([k (in-list (find-relevant-directories '(scribblings) 'no-planet))])
+      (for/hash ([k (in-list (find-relevant-directories (list tag) 'no-planet))])
         (values k #t))))
   (apply
    append
-   (for*/list ([dir (find-relevant-directories '(scribblings) 'all-available)]
+   (for*/list ([dir (find-relevant-directories (list tag) 'all-available)]
                [d (let ([info-proc (get-info/full dir)])
                     (if info-proc
-                        (info-proc 'scribblings)
+                        (info-proc tag)
                         '()))])
      (unless (and (list? d) (pair? d))
        (error 'xref "bad scribblings entry: ~e" d))
@@ -63,7 +63,11 @@
                                           (exn-message exn)
                                           (format "~e" exn)))
                                      #f)])
-          (cadr (call-with-input-file* dest fasl->s-exp))))))
+          (make-data+root
+           ;; data to deserialize:
+           (cadr (call-with-input-file* dest fasl->s-exp))
+           ;; provide a root for deserialization:
+           (path-only dest))))))
 
 (define (make-key->source db-path no-user?)
   (define main-db (cons (or db-path
@@ -119,7 +123,8 @@
 
 (define (get-reader-thunks no-user? done-ht)
   (map (dest->source done-ht)
-       (filter values (get-dests no-user?))))
+       (filter values (append (get-dests 'scribblings no-user?)
+                              (get-dests 'rendered-scribblings no-user?)))))
 
 (define (load-collections-xref [report-loading void])
   (or cached-xref

collects/tests/pkg/test-docs.rkt

@@ -0,0 +1,50 @@
+#lang racket/base
+(require setup/xref
+         scribble/xref
+         racket/path
+         net/url
+         rackunit)
+
+;; The `test-docs-...' functions are meant to be called via "tests-binary.rkt"
+(provide test-docs-x
+         test-docs-y
+         test-docs-r)
+
+(define xref (load-collections-xref))
+
+(define (test here? tag)
+  (check-equal? here? (and tag #t))
+  (when tag
+    (define-values (p a) (xref-tag->path+anchor xref tag))
+    (check-true (path? p))
+    (call-with-input-file* 
+     p
+     (lambda (in)
+       (define m (regexp-match #rx"<script [^>]*src=\"([^\"]*)local-redirect.js\"[^>]*>" in))
+       (define ref (url->path
+                    (string->url
+                     (bytes->string/utf-8
+                      (if (equal? (cadr m) #"")
+                          #"."
+                          (cadr m))))))
+       (define path (if (absolute-path? ref)
+                        (build-path ref
+                                    "local-redirect.js")
+                        (build-path (path-only p)
+                                    ref
+                                    "local-redirect.js")))
+       (check-true (file-exists? path))))))
+
+(define (test-docs-x here?)
+  (when (collection-path "x" #:fail (lambda (x) #f))
+    (namespace-require '(for-label x)))
+  (test here? (xref-binding->definition-tag xref (eval '#'x) #f)))
+
+(define (test-docs-y here?)
+  (when (collection-path "y" #:fail (lambda (x) #f))
+    (namespace-require '(for-label y)))
+  (test here? (xref-binding->definition-tag xref (eval '#'y) #f)))
+
+(define (test-docs-r here?)
+  (namespace-require '(for-label racket/base))
+  (test here? (xref-binding->definition-tag xref (eval '#'lambda) #f)))

collects/tests/pkg/test-pkgs/.gitignore

@@ -4,3 +4,4 @@ MANIFEST
 *plt
 *CHECKSUM
 pkg-test1b*
+/src-pkg/

collects/tests/pkg/test-pkgs/pkg-x/info.rkt

@@ -0,0 +1,7 @@
+#lang setup/infotab
+
+(define deps '("pkg-z"))
+(define build-deps '("pkg-y"))
+
+(define binary-omit-files '("nobin-top.txt"))
+(define source-omit-files '("nosrc-top.txt"))

collects/tests/pkg/test-pkgs/pkg-x/x/info.rkt

@@ -0,0 +1,9 @@
+#lang setup/infotab
+
+(define scribblings '(("x.scrbl")))
+
+(define binary-omit-files '("nobin.txt"))
+(define source-omit-files '("nosrc.txt"))
+
+(define binary-keep-files '("keep.scrbl"))
+(define source-keep-files '("keep/doc"))

collects/tests/pkg/test-pkgs/pkg-x/x/keep.scrbl

@@ -0,0 +1,3 @@
+#lang scribble/base
+
+Keep

collects/tests/pkg/test-pkgs/pkg-x/x/keep/doc/keep.txt

@@ -0,0 +1 @@
+Keep this.

collects/tests/pkg/test-pkgs/pkg-x/x/main.rkt

@@ -0,0 +1,7 @@
+#lang racket/base
+(require z)
+
+(provide x)
+
+(define (x) 
+  (if (eq? (z) 'z) 'x 'ouch))

collects/tests/pkg/test-pkgs/pkg-x/x/x.scrbl

@@ -0,0 +1,10 @@
+#lang scribble/manual
+@(require (for-label x y racket/base))
+
+@title{X}
+
+@defmodule[x]
+
+@defproc[(x) symbol?]{
+
+The same as @racket[y], but returns @racket['x]}

collects/tests/pkg/test-pkgs/pkg-y/info.rkt

@@ -0,0 +1,4 @@
+#lang setup/infotab
+
+(define build-deps '("pkg-x"))
+

collects/tests/pkg/test-pkgs/pkg-y/y/info.rkt

@@ -0,0 +1,3 @@
+#lang setup/infotab
+
+(define scribblings '(("y.scrbl")))

collects/tests/pkg/test-pkgs/pkg-y/y/main.rkt

@@ -0,0 +1,6 @@
+#lang racket/base
+
+(provide y)
+
+(define (y) 
+  (if (zero? (random 1)) 'y 'ouch))

collects/tests/pkg/test-pkgs/pkg-y/y/y.scrbl

@@ -0,0 +1,10 @@
+#lang scribble/manual
+@(require (for-label y x racket/base))
+
+@title{Y}
+
+@defmodule[y]
+
+@defproc[(y) symbol?]{
+
+The same as @racket[y], but returns @racket['y]}

collects/tests/pkg/test-pkgs/pkg-z/info.rkt

@@ -0,0 +1,2 @@
+#lang setup/infotab
+

collects/tests/pkg/test-pkgs/pkg-z/z/main.rkt

@@ -0,0 +1,7 @@
+#lang racket/base
+(provide z)
+
+(define z #f)
+(set! z (lambda () 'z))
+
+

collects/tests/pkg/test.rkt

@@ -54,4 +54,5 @@
  "versions"
  "platform"
  "raco"
+ "binary"
  "catalogs")

collects/tests/pkg/tests-binary.rkt

@@ -0,0 +1,126 @@
+#lang racket/base
+(require "shelly.rkt"
+         "util.rkt"
+         racket/file
+         file/unzip)
+
+(pkg-tests
+
+ $ "raco pkg install --deps fail test-pkgs/pkg-x/" =exit> 1
+ $ "raco pkg install --deps fail test-pkgs/pkg-y/" =exit> 1
+ $ "raco pkg install --deps fail test-pkgs/pkg-x/ test-pkgs/pkg-z/" =exit> 1
+ $ "raco pkg install --deps fail test-pkgs/pkg-y/ test-pkgs/pkg-z/" =exit> 1
+ $ "raco pkg install --deps fail test-pkgs/pkg-x/ test-pkgs/pkg-y/" =exit> 1
+ $ "raco pkg install --deps fail test-pkgs/pkg-y/ test-pkgs/pkg-x/" =exit> 1
+
+ $ "raco pkg install --deps fail test-pkgs/pkg-z/" =exit> 0
+
+ (putenv "PLT_PKG_NOSETUP" "")
+ $ "raco pkg install test-pkgs/pkg-x/ test-pkgs/pkg-y/"
+ (putenv "PLT_PKG_NOSETUP" "1")
+
+ $ "racket -l racket/base -l x -e '(x)'" =stdout> "'x\n"
+ $ "racket -l racket/base -l y -e '(y)'" =stdout> "'y\n"
+
+ $ "racket -l racket/base -t test-docs.rkt -e '(test-docs-x #t)'"
+ $ "racket -l racket/base -t test-docs.rkt -e '(test-docs-y #t)'"
+
+ (make-directory* "test-pkgs/src-pkgs")
+ $ "raco pkg create --from-install --source --dest test-pkgs/src-pkgs pkg-x"
+ $ "raco pkg create --from-install --source --dest test-pkgs/src-pkgs pkg-y"
+ $ "raco pkg create --from-install --source --dest test-pkgs/src-pkgs pkg-z"
+
+ $ "raco pkg create --from-install --binary --dest test-pkgs pkg-x"
+ $ "raco pkg create --from-install --binary --dest test-pkgs pkg-y"
+ $ "raco pkg create --from-install --binary --dest test-pkgs pkg-z"
+
+ (putenv "PLT_PKG_NOSETUP" "")
+ $ "raco pkg remove pkg-x pkg-y pkg-z"
+ (putenv "PLT_PKG_NOSETUP" "1")
+
+ $ "racket -l racket/base -t test-docs.rkt -e '(test-docs-x #f)'"
+ $ "racket -l racket/base -t test-docs.rkt -e '(test-docs-y #f)'"
+
+ (define tmp-dir (make-temporary-file "unpack-~a" 'directory))
+ (make-directory* tmp-dir)
+ (define (unpack name)
+   (define orig-d (current-directory))
+   (let ([z (path->complete-path (format "test-pkgs/src-pkgs/pkg-~a.zip" name))])
+     (define d (build-path tmp-dir name))
+     (make-directory* d)
+     (parameterize ([current-directory d])
+       (unzip z)
+       (for ([f (in-directory)])
+         (define orig-f (build-path orig-d (format "test-pkgs/pkg-~a" name) f))
+         (unless (if (file-exists? f)
+                     (file-exists? orig-f)
+                     (directory-exists? orig-f))
+           (error 'diff "extra ~s" f))
+         (when (file-exists? f)
+           (unless (equal? (file->bytes f)
+                           (file->bytes orig-f))
+             (error 'diff "file differs ~s" f)))))
+     (parameterize ([current-directory (format "test-pkgs/pkg-~a" name)])
+       (for ([f (in-directory)])
+         (define new-f (build-path d f))
+         (unless (if (file-exists? f)
+                     (file-exists? new-f)
+                     (directory-exists? new-f))
+           (unless (regexp-match? #rx#"nosrc" (path->bytes f))
+             (error 'diff "missing ~s" new-f)))))))
+ (unpack "x")
+ (unpack "y")
+ (unpack "z")
+ (delete-directory/files tmp-dir)
+
+ (make-directory* tmp-dir)
+ (define (unpack-bin name)
+   (let ([z (path->complete-path (format "test-pkgs/pkg-~a.zip" name))])
+     (define d (build-path tmp-dir name))
+     (make-directory* d)
+     (parameterize ([current-directory d])
+       (unzip z)
+       (for ([f (in-directory)])
+         (when (or (regexp-match? #rx#"[.](?:rkt|scrbl)$" (path->bytes f))
+                   (regexp-match? #rx#"nobin" (path->bytes f)))
+           (unless (regexp-match? #rx#"(?:info[.]rkt|keep.scrbl)$" (path->bytes f))
+             (error 'binary "extra ~s" f)))))))
+ (unpack-bin "x")
+ (unpack-bin "y")
+ (unpack-bin "z")
+ (delete-directory/files tmp-dir)
+
+ (shelly-case
+  "source-package dependencies like original"
+  $ "raco pkg install --deps fail test-pkgs/src-pkgs/pkg-x.zip" =exit> 1
+  $ "raco pkg install --deps fail test-pkgs/src-pkgs/pkg-y.zip" =exit> 1
+  $ "raco pkg install --deps fail test-pkgs/src-pkgs/pkg-x.zip test-pkgs/src-pkgs/pkg-z.zip" =exit> 1
+  $ "raco pkg install --deps fail test-pkgs/src-pkgs/pkg-y.zip test-pkgs/src-pkgs/pkg-z.zip" =exit> 1
+  $ "raco pkg install --deps fail test-pkgs/src-pkgs/pkg-x.zip test-pkgs/src-pkgs/pkg-y.zip" =exit> 1
+  $ "raco pkg install --deps fail test-pkgs/src-pkgs/pkg-y.zip test-pkgs/src-pkgs/pkg-x.zip" =exit> 1)
+
+ (shelly-case
+  "binary-package dependencies are less"
+  $ "raco pkg install --deps fail test-pkgs/pkg-x.zip" =exit> 1
+  
+  $ "raco pkg install --deps fail test-pkgs/pkg-x.zip test-pkgs/pkg-z.zip"
+  $ "raco pkg remove pkg-x pkg-z"
+  $ "raco pkg install --deps fail test-pkgs/pkg-y.zip"
+  $ "raco pkg remove pkg-y")
+
+ (putenv "PLT_PKG_NOSETUP" "")
+ $ "raco pkg install --deps fail test-pkgs/pkg-y.zip"
+ (putenv "PLT_PKG_NOSETUP" "1")
+
+ $ "racket -l racket/base -t test-docs.rkt -e '(test-docs-x #f)'"
+ $ "racket -l racket/base -t test-docs.rkt -e '(test-docs-y #t)'"
+
+ (shelly-case
+  "check that cleaning doesn't destroy a binary install"
+  $ "racket -l y"
+  $ "raco setup -c -l y"
+  $ "racket -l y")
+
+ $ "raco pkg remove pkg-y"
+
+ )