diff --git a/pkgs/plt-services/meta/pkg-build/main.rkt b/pkgs/plt-services/meta/pkg-build/main.rkt index 27583bb00a..17d8d10cd3 100644 --- a/pkgs/plt-services/meta/pkg-build/main.rkt +++ b/pkgs/plt-services/meta/pkg-build/main.rkt @@ -17,7 +17,7 @@ (provide build-pkgs) (define-runtime-path pkg-list-rkt "pkg-list.rkt") -(define-runtime-path pkg-docs-rkt "pkg-docs.rkt") +(define-runtime-path pkg-adds-rkt "pkg-adds.rkt") ;; ---------------------------------------- @@ -37,8 +37,8 @@ ;; needed by `racket/draw`) ;; ;; FIXME: -;; - handle conflicting doc names ;; - check that declared dependencies are right +;; - run tests (define (build-pkgs ;; Besides a running Racket, the host machine must provide @@ -65,21 +65,18 @@ ;; + pkgs/P.zip ;; + P.zip.CHECKSUM ;; => up-to-date and successful, - ;; docs/P-docs.rktd has doc listing, and + ;; docs/P-adds.rktd listing of docs, exes, etc., and ;; success/P records success ;; * pkgs/P.orig-CHECKSUM matching archived catalog ;; + fail/P ;; => up-to-date and failed ;; - ;; "dumpster" --- saved builds of failed packages - ;; if the package at least installs, and maybe the - ;; attempt builds some documentation + ;; "dumpster" --- saved builds of failed packages if the + ;; package at least installs; maybe the attempt built + ;; some documentation ;; ;; A package is rebuilt if its checksum changes or if one of ;; its declared dependencies changes. - ;; - ;; Currently, package-level dependencies are not checked, and - ;; tests are not yet run. ;; URL to provide the installer and pre-built packages: #:snapshot-url snapshot-url @@ -150,7 +147,7 @@ (define dumpster-dir (build-path work-dir "dumpster")) (define dumpster-pkgs-dir (build-path dumpster-dir "pkgs/")) - (define dumpster-docs-dir (build-path dumpster-dir "docs")) + (define dumpster-adds-dir (build-path dumpster-dir "adds")) (define snapshot-catalog (url->string @@ -167,7 +164,7 @@ (printf ">> ") (apply substatus fmt args)) - (define (show-list nested-strs) + (define (show-list nested-strs #:indent [indent ""]) (define strs (let loop ([strs nested-strs]) (cond [(null? strs) null] @@ -181,11 +178,11 @@ (cdr strs)))] [else (cons (car strs) (loop (cdr strs)))]))) (substatus "~a\n" - (for/fold ([a ""]) ([s (in-list strs)]) + (for/fold ([a indent]) ([s (in-list strs)]) (if ((+ (string-length a) 1 (string-length s)) . > . 72) (begin (substatus "~a\n" a) - (string-append " " s)) + (string-append indent " " s)) (string-append a " " s))))) ;; ---------------------------------------- @@ -365,7 +362,7 @@ (ssh "cd " (q vm-dir) " && " " sh " (q installer-name) " --in-place --dest ./racket") ;; VM-side helper modules: - (scp pkg-docs-rkt (at-vm (~a vm-dir "/pkg-docs.rkt"))) + (scp pkg-adds-rkt (at-vm (~a vm-dir "/pkg-adds.rkt"))) (scp pkg-list-rkt (at-vm (~a vm-dir "/pkg-list.rkt"))) ;; ---------------------------------------- @@ -385,11 +382,11 @@ ;; ---------------------------------------- (status "Stashing installation docs\n") (ssh cd-racket - " && bin/racket ../pkg-docs.rkt --all > ../pkg-docs.rktd") + " && bin/racket ../pkg-adds.rkt --all > ../pkg-adds.rktd") (ssh cd-racket " && tar zcf ../install-doc.tgz doc") - (scp (at-vm (~a vm-dir "/pkg-docs.rktd")) - (build-path work-dir "install-docs.rktd")) + (scp (at-vm (~a vm-dir "/pkg-adds.rktd")) + (build-path work-dir "install-adds.rktd")) (scp (at-vm (~a vm-dir "/install-doc.tgz")) (build-path work-dir "install-doc.tgz")) @@ -613,15 +610,15 @@ (sync (system-idle-evt)) ;; ---------------------------------------- - (make-directory* (build-path built-dir "docs")) + (make-directory* (build-path built-dir "adds")) (make-directory* fail-dir) (make-directory* success-dir) (make-directory* dumpster-pkgs-dir) - (make-directory* dumpster-docs-dir) + (make-directory* dumpster-adds-dir) - (define (pkg-docs-file pkg) - (build-path built-dir "docs" (format "~a-docs.rktd" pkg))) + (define (pkg-adds-file pkg) + (build-path built-dir "adds" (format "~a-adds.rktd" pkg))) (define (complain failure-dest fmt . args) (when failure-dest @@ -702,8 +699,8 @@ ;; even on failure. We'll put it in the "dumpster". (or ok? one-pkg) (ssh cd-racket - " && bin/racket ../pkg-docs.rkt " pkgs-str - " > ../pkg-docs.rktd" + " && bin/racket ../pkg-adds.rkt " pkgs-str + " > ../pkg-adds.rktd" #:mode 'result #:failure-dest (and ok? failure-dest)) (for/and ([pkg (in-list flat-pkgs)]) @@ -722,8 +719,8 @@ built-pkgs-dir) (scp (at-vm (~a vm-dir "/built/" pkg ".zip.CHECKSUM")) built-pkgs-dir) - (scp (at-vm (~a vm-dir "/pkg-docs.rktd")) - (build-path built-dir "docs" (format "~a-docs.rktd" pkg))) + (scp (at-vm (~a vm-dir "/pkg-adds.rktd")) + (build-path built-dir "adds" (format "~a-adds.rktd" pkg))) (call-with-output-file* (build-path success-dir pkg) #:exists 'truncate/replace @@ -749,8 +746,8 @@ (scp (at-vm (~a vm-dir "/built/" pkg ".zip.CHECKSUM")) dumpster-pkgs-dir #:mode 'ignore-failure) - (scp (at-vm (~a vm-dir "/pkg-docs.rktd")) - (build-path dumpster-docs-dir (format "~a-docs.rktd" pkg)) + (scp (at-vm (~a vm-dir "/pkg-adds.rktd")) + (build-path dumpster-adds-dir (format "~a-adds.rktd" pkg)) #:mode 'ignore-failure))) (substatus "*** failed ***\n")]) ok?) @@ -789,19 +786,68 @@ (file-exists? (pkg-zip-checksum-file pkg))))) pkg)) - (define doc-pkgs - (for/set ([pkg (in-set available-pkgs)] - #:when - (let () - (define docs-file (pkg-docs-file pkg)) - (define ht (call-with-input-file* docs-file read)) - (pair? (hash-ref ht pkg null)))) - pkg)) - - (define doc-pkg-list (sort (set->list doc-pkgs) string . 1)) + (cons k v))) + (cond + [(null? conflicts) + doc-pkgs] + [else + (substatus "Install conflicts:\n") + (for ([v (in-list conflicts)]) + (substatus " ~a ~s:\n" (caar v) (cdar v)) + (show-list #:indent " " (sort (set->list (cdr v)) stringlist disallowed-pkgs) stringset doc-pkg-list) disallowed-pkgs)]))) + + (define no-conflict-doc-pkg-list (sort (set->list no-conflict-doc-pkgs) string documentation mapping. + +(define all-pkgs? #f) + +(define want-pkgs + (command-line + #:once-each + [("--all") "All packages" + (set! all-pkgs? #t)] + #:args + want-pkg + want-pkg)) + +(define ns (make-base-namespace)) + +(define ht + (for/hash ([pkg (in-list + (if all-pkgs? + (installed-pkg-names #:scope 'installation) + want-pkgs))]) + (define dir (pkg-directory pkg)) + (values pkg + (pkg-directory->additional-installs dir pkg #:namespace ns)))) + +(write ht) +(newline) diff --git a/pkgs/plt-services/meta/pkg-build/pkg-docs.rkt b/pkgs/plt-services/meta/pkg-build/pkg-docs.rkt deleted file mode 100644 index 23dfbfe4f7..0000000000 --- a/pkgs/plt-services/meta/pkg-build/pkg-docs.rkt +++ /dev/null @@ -1,51 +0,0 @@ -#lang racket/base -(require racket/cmdline - setup/getinfo - setup/dirs - pkg/path) - -;; This module is copied to the virtual machine to extract -;; a package -> documentation mapping. - -(define all-pkgs? #f) - -(define want-pkgs - (command-line - #:once-each - [("--all") "All packages" - (set! all-pkgs? #t)] - #:args - want-pkg - want-pkg)) - -(define dirs (find-relevant-directories '(scribblings))) -(define cache (make-hash)) - -(define ht - (for/fold ([ht (hash)]) ([dir (in-list dirs)]) - (define pkg (path->pkg dir #:cache cache)) - (cond - [(or all-pkgs? - (member pkg want-pkgs)) - (define i (get-info/full dir)) - (define scribblings (if i (i 'scribblings (lambda () null)) null)) - (for/fold ([ht ht]) ([scribbling (in-list scribblings)]) - (cond - [(and (list? scribbling) - (<= 1 (length scribbling) 6) - (path-string? (car scribbling)) - (or (< (length scribbling) 4) - (string? (list-ref scribbling 3)))) - (define path (path->complete-path (car scribbling) dir)) - (define name - (cond - [(>= (length scribbling) 4) - (list-ref scribbling 3)] - [else - (define-values (base name dir?) (split-path path)) - (path->string (path-replace-suffix name #""))])) - (hash-update ht pkg (lambda (l) (cons name l)) null)] - [else ht]))] - [else ht]))) - -(write ht) (newline)