1#lang racket/base 2(require syntax/modread 3 syntax/modcollapse 4 syntax/modresolve 5 pkg/lib 6 pkg/name 7 racket/set 8 racket/string 9 racket/list 10 setup/getinfo 11 racket/file 12 racket/path 13 setup/dirs 14 setup/doc-db 15 version/utils 16 compiler/cross 17 compiler/private/dep 18 "time.rkt") 19 20(provide check-package-dependencies) 21 22(define core-pkg "base") 23 24;; Submodules with these names are dropped in binary 25;; packages, so they only controbute to `build-deps': 26(define build-only-submod-names '(test doc srcdoc)) 27 28(define (check-package-dependencies 29 paths 30 coll-paths 31 coll-main?s 32 coll-modes 33 setup-printf setup-fprintf report-error 34 check-unused? fix? verbose? 35 all-pkgs-lazily? 36 must-declare-deps?) 37 ;; Tables 38 (define missing (make-hash)) 39 (define skip-pkgs (make-hash)) 40 (define pkg-internal-deps (make-hash)) ; dependencies available for a package's own use 41 (define pkg-immediate-deps (make-hash)) ; save immediate dependencies 42 (define pkg-external-deps (make-hash)) ; dependencies made available though `implies' 43 (define pkg-actual-deps (make-hash)) ; found dependencies (when checking for unused) 44 (define pkg-implies (make-hash)) ; for checking unused 45 (define pkg-reps (make-hash)) ; for union-find on external deps 46 (define mod-pkg (make-hash)) 47 (define dup-mods (make-hash)) ; modules that are provided by multiple packages 48 (define pkg-version-deps (make-hash)) ; save version dependencies 49 (define pkg-versions (make-hash)) ; save declared versions 50 (define path-cache (make-hash)) 51 (define metadata-ns (make-base-namespace)) 52 (define pkg-dir-cache (make-hash)) 53 (define missing-pkgs (make-hash)) 54 55 (hash-set! pkg-internal-deps "racket" (list (set) (set))) 56 (hash-set! pkg-external-deps "racket" (set)) 57 (hash-set! pkg-reps "racket" "racket") 58 59 ;; ---------------------------------------- 60 ;; printinf helpers: 61 (define (setup-printf* task s . args) 62 (for ([s (string-split (apply format s args) "\n")]) 63 (setup-printf task s))) 64 (define (setup-fprintf* o task s . args) 65 (for ([s (string-split (apply format s args) "\n")]) 66 (setup-fprintf o task s))) 67 68 ;; ---------------------------------------- 69 ;; Find the canonical representative for a set of external dependencies: 70 (define (find-rep! pkg) 71 (define rep-pkg (hash-ref pkg-reps pkg)) 72 (if (equal? rep-pkg pkg) 73 pkg 74 (let ([rep-pkg (find-rep! rep-pkg)]) 75 (hash-set! pkg-reps pkg rep-pkg) 76 rep-pkg))) 77 78 ;; ---------------------------------------- 79 ;; Equate `a-pkg' and `b-pkg', returning a representative: 80 (define (union-find! a-pkg b-pkg) 81 (define rep-a-pkg (find-rep! a-pkg)) 82 (define rep-b-pkg (find-rep! b-pkg)) 83 (unless (equal? rep-a-pkg rep-b-pkg) 84 (define a-deps (hash-ref pkg-reps rep-a-pkg)) 85 (define b-deps (hash-ref pkg-reps rep-b-pkg)) 86 (hash-set! pkg-reps rep-b-pkg (set-union a-deps b-deps)) 87 (hash-remove! pkg-external-deps rep-a-pkg) 88 (hash-set! pkg-reps rep-a-pkg rep-b-pkg)) 89 rep-b-pkg) 90 91 ;; ---------------------------------------- 92 ;; Check whether another package has already declared a module: 93 (define (check-module-declaration mod pkg) 94 (let ([already-pkg (hash-ref mod-pkg mod #f)]) 95 (when already-pkg 96 (setup-fprintf* (current-error-port) #f 97 (string-append 98 "module provided by multiple packages:\n" 99 " module: ~s\n" 100 " providing package: ~s\n" 101 " other providing package: ~s\n") 102 mod 103 pkg 104 already-pkg) 105 (hash-update! dup-mods mod 106 (lambda (ht) 107 (hash-set (hash-set ht pkg #t) already-pkg #t)) 108 #hash())))) 109 110 ;; ---------------------------------------- 111 ;; Get a package's info, returning its deps and implies: 112 (define (get-immediate-pkg-info! pkg dep-of) 113 (define dir (pkg-directory pkg #:cache pkg-dir-cache)) 114 (unless dir 115 (unless (hash-ref missing-pkgs pkg #f) 116 (hash-set! missing-pkgs pkg #t) 117 (setup-fprintf* (current-error-port) #f 118 "package not installed: ~s~a" 119 pkg 120 (if dep-of 121 (format "\n dependency of: ~a" dep-of) 122 "")))) 123 ;; Get package information: 124 (define-values (checksum mods deps+build-deps+vers) 125 (cond 126 [dir 127 (get-pkg-content (pkg-desc (if (path? dir) (path->string dir) dir) 'dir pkg #f #f) 128 #:namespace metadata-ns 129 #:extract-info (lambda (i) 130 (cons 131 (if (and i 132 (or (i 'deps (lambda () #f)) 133 (i 'build-deps (lambda () #f)))) 134 (cons 135 (extract-pkg-dependencies i 136 #:build-deps? #f 137 #:filter? #t 138 #:versions? #t) 139 (extract-pkg-dependencies i 140 #:filter? #t 141 #:versions? #t)) 142 #f) 143 (and i (i 'version (lambda () #f))))))] 144 [else (values #f null (cons (cons null null) #f))])) 145 (define vers (cdr deps+build-deps+vers)) 146 (define deps+build-deps (car deps+build-deps+vers)) 147 (unless (or deps+build-deps must-declare-deps?) 148 (hash-set! skip-pkgs pkg #t) 149 (setup-printf #f "package declares no dependencies: ~s" pkg)) 150 (define deps+vers (if deps+build-deps 151 (filter-map (lambda (p) 152 (define n (package-source->name (car p))) 153 (and n (cons n (cadr p)))) 154 (cdr deps+build-deps)) 155 '())) 156 (define deps (map car deps+vers)) 157 (define runtime-deps (if deps+build-deps 158 (list->set (filter-map package-source->name 159 (map car (car deps+build-deps)))) 160 (set))) 161 (define implies 162 (list->set (let ([i (and dir (get-info/full dir #:namespace metadata-ns))]) 163 (if i 164 (i 'implies (lambda () null)) 165 null)))) 166 ;; check that `implies' is a subset of `deps' 167 (for ([i (in-set implies)]) 168 (unless (eq? i 'core) 169 (unless (set-member? runtime-deps i) 170 (setup-fprintf* (current-error-port) #f 171 (string-append 172 "implied package is not declared as a dependency:\n" 173 " in package: ~s\n" 174 " implied package: ~s\n") 175 pkg 176 i)))) 177 (for ([mod (in-list mods)]) 178 (check-module-declaration mod pkg) 179 (hash-set! mod-pkg mod pkg)) 180 ;; Save immediate dependencies, initialize external dependencies: 181 (hash-set! pkg-reps pkg pkg) 182 (hash-set! pkg-immediate-deps pkg (list 183 (set-add runtime-deps 184 pkg) 185 (set-add (list->set deps) 186 pkg))) 187 (hash-set! pkg-version-deps pkg (for/list ([d (in-list deps+vers)] 188 #:when (cdr d)) 189 d)) 190 (hash-set! pkg-external-deps pkg (set-add (set-intersect 191 implies 192 (set-add runtime-deps 193 'core)) 194 pkg)) 195 (when vers 196 (hash-set! pkg-versions pkg vers)) 197 (when check-unused? 198 (hash-set! pkg-implies pkg implies)) 199 (values deps implies)) 200 201 ;; ---------------------------------------- 202 ;; Flatten package dependencies, record mod->pkg mappings, 203 ;; return representative package name (of a recursive set) 204 (define (register-pkg! pkg ancestors dep-of) 205 (cond 206 [(hash-ref pkg-reps pkg #f) 207 => (lambda (rep-pkg) rep-pkg)] 208 [else 209 (when verbose? 210 (setup-printf #f " checking dependencies of ~s" pkg)) 211 (define-values (deps implies) (get-immediate-pkg-info! pkg dep-of)) 212 ;; Recur on all dependencies 213 (define new-ancestors (hash-set ancestors pkg #t)) 214 (define rep-pkg 215 (for/fold ([rep-pkg pkg]) ([dep (in-list deps)]) 216 (define dep-rep-pkg (register-pkg! dep ancestors pkg)) 217 (cond 218 [(not (set-member? implies dep)) 219 ;; not implied, so doesn't add external dependencies 220 rep-pkg] 221 [(equal? dep-rep-pkg rep-pkg) 222 ;; an "implies" cycle that points back here - done! 223 rep-pkg] 224 [(hash-ref ancestors dep-rep-pkg #f) 225 ;; an "implies" cycle back to an ancestor; union to ancestor 226 (union-find! rep-pkg dep-rep-pkg)] 227 [else 228 ;; assert: external deps of `dep-rep-pkg' will not change anymore 229 (define new-rep-pkg (find-rep! rep-pkg)) 230 (hash-set! pkg-external-deps 231 rep-pkg 232 (set-union (hash-ref pkg-external-deps dep-rep-pkg) 233 (hash-ref pkg-external-deps new-rep-pkg))) 234 new-rep-pkg]))) 235 rep-pkg])) 236 237 ;; ---------------------------------------- 238 ;; Fill in package internal dependencies, given that immediate-dependency 239 ;; external-dependency information is available for all relevant packages: 240 (define (init-pkg-internals! pkg) 241 (unless (hash-ref pkg-internal-deps pkg #f) 242 ;; register modules and compute externally visible dependencies 243 (register-pkg! pkg (hash) #f) 244 ;; combine flattened external dependencies to determine internal dependencies 245 (define (flatten imm-deps) 246 (for/fold ([deps (set)]) ([dep (in-set imm-deps)]) 247 (set-union deps 248 (hash-ref pkg-external-deps (find-rep! dep))))) 249 (let ([imm-depss (hash-ref pkg-immediate-deps pkg)]) 250 (hash-set! pkg-internal-deps 251 pkg 252 (map flatten imm-depss)) 253 (when check-unused? 254 (hash-set! pkg-actual-deps 255 pkg 256 (map (lambda (ignored) (make-hash)) imm-depss)))) 257 (when verbose? 258 (define (make-list s) 259 (apply 260 string-append 261 (for/list ([k (in-set s)]) 262 (format "\n ~s" k)))) 263 (setup-printf* #f 264 (string-append 265 " declared accesses, counting `implies'\n" 266 " for package: ~s\n" 267 " packages:~a\n" 268 " packages for build:~a\n") 269 pkg 270 (make-list (car (hash-ref pkg-internal-deps pkg))) 271 (make-list (cadr (hash-ref pkg-internal-deps pkg))))))) 272 273 ;; ---------------------------------------- 274 ;; Check use of `src-pkg' (in `mode') from `pkg': 275 (define (check-dep! pkg src-pkg mode) 276 (define flat-depss (hash-ref pkg-internal-deps pkg)) 277 (when check-unused? 278 (define actual-depss (hash-ref pkg-actual-deps pkg)) 279 (hash-set! (if (eq? mode 'run) (car actual-depss) (cadr actual-depss)) 280 src-pkg 281 #t)) 282 (or (set-member? (if (eq? mode 'run) 283 (car flat-depss) 284 (cadr flat-depss)) 285 src-pkg) 286 (begin 287 (hash-update! missing pkg 288 (lambda (h) 289 (hash-update h src-pkg 290 (lambda (old-mode) 291 (if (eq? mode old-mode) 292 mode 293 'run)) 294 mode)) 295 (hash)) 296 #f))) 297 298 ;; ---------------------------------------- 299 ;; Check use of `mod' (in `mode') from `pkg' by file `f': 300 (define reported (make-hash)) 301 (define (check-mod! mod mode pkg f dir) 302 (when (and all-pkgs-lazily? 303 (not (hash-ref mod-pkg mod #f))) 304 (define path (resolve-module-path mod #f)) 305 (define pkg (path->pkg path #:cache path-cache)) 306 (when pkg 307 (init-pkg-internals! pkg))) 308 (define src-pkg (or (hash-ref mod-pkg mod #f) 309 'core)) 310 (when src-pkg 311 (unless (check-dep! pkg src-pkg mode) 312 (define key (list pkg src-pkg (path-replace-extension f #"") mod)) 313 (unless (hash-ref reported key #f) 314 (hash-set! reported key #t) 315 (setup-fprintf* (current-error-port) #f 316 (string-append 317 "found undeclared dependency:\n" 318 " mode: ~s\n" 319 " for package: ~s\n" 320 " on package: ~s\n" 321 " dependent source: ~a\n" 322 " used module: ~s") 323 mode 324 pkg 325 src-pkg 326 (build-path dir f) 327 mod))))) 328 329 330 ;; ---------------------------------------- 331 (define doc-pkgs (make-hash)) 332 (define doc-reported (make-hash)) 333 (define doc-all-registered? #f) 334 (define (check-doc! pkg dep dest-dir) 335 (define-values (base name dir?) (split-path dep)) 336 (when (and all-pkgs-lazily? 337 (not doc-all-registered?) 338 (not (hash-ref doc-pkgs base #f))) 339 (set! doc-all-registered? #t) 340 (register-all-docs!)) 341 (define src-pkg (hash-ref doc-pkgs base #f)) 342 (when src-pkg 343 (unless (check-dep! pkg src-pkg 'build) 344 (define key (list base dest-dir)) 345 (unless (hash-ref doc-reported key #f) 346 (define (get-name p) 347 (define-values (b n d?) (split-path p)) 348 (path-element->string n)) 349 (hash-set! doc-reported key #t) 350 (setup-fprintf* (current-error-port) #f 351 (string-append 352 "found undeclared dependency:\n" 353 " mode: build (of documentation)\n" 354 " for package: ~s\n" 355 " on package: ~s\n" 356 " from document: ~s\n" 357 " to document: ~s") 358 pkg 359 src-pkg 360 (get-name dest-dir) 361 (get-name base)))))) 362 363 ;; ---------------------------------------- 364 (define (check-bytecode-deps f dir coll-path pkg) 365 (define zo-f (path-replace-extension f #".zo")) 366 (when (file-exists? (build-path dir zo-f)) 367 (define base (let ([m (regexp-match #rx#"^(.*)_[^_]+[.]zo$" 368 (path-element->bytes zo-f))]) 369 (or (and m (bytes->string/utf-8 (cadr m))) 370 ;; In case the original file name had no suffix: 371 "unknown"))) 372 (define in-mod (if (module-path? base) 373 `(lib ,(string-join 374 (append (map path-element->string coll-path) (list base)) 375 "/")) 376 (build-path dir base))) 377 (define zo-path (build-path dir zo-f)) 378 (let/ec esc 379 (define mod-code (with-handlers ([exn:fail? (lambda (exn) 380 (report-error exn) 381 (esc (void)))]) 382 (call-with-input-file* 383 zo-path 384 (lambda (i) 385 (parameterize ([read-accept-compiled #t] 386 [read-on-demand-source zo-path]) 387 (read i)))))) 388 ;; Recur to cover submodules: 389 (let loop ([mod-code mod-code]) 390 (define name (module-compiled-name mod-code)) 391 (unless (and (list? name) 392 (memq (last name) build-only-submod-names)) 393 ;; Check the module's imports: 394 (for* ([imports (in-list (module-compiled-imports mod-code))] 395 [import (cdr imports)]) 396 (define mod (let ([m (collapse-module-path-index import in-mod)]) 397 (if (and (pair? m) 398 (eq? (car m) 'submod)) 399 (cadr m) 400 m))) 401 (when (and (pair? mod) (eq? 'lib (car mod))) 402 (check-mod! mod 'run pkg zo-f dir))) 403 ;; Recur for submodules: 404 (for-each loop 405 (append 406 (module-compiled-submodules mod-code #t) 407 (module-compiled-submodules mod-code #f)))))))) 408 409 ;; ---------------------------------------- 410 (define (find-compiled-directories path) 411 ;; Find all directories that can hold compiled bytecode for 412 ;; `path`. When cross-compiling, only list directories targeting 413 ;; the host machine. 414 (define roots 415 (let ([roots (current-compiled-file-roots)]) 416 (if (cross-multi-compile? roots) 417 (list (car roots)) 418 roots))) 419 (filter 420 values 421 (for*/list ([root (in-list roots)] 422 [mode (in-list (use-compiled-file-paths))]) 423 (define compiled-dir 424 (cond 425 [(eq? root 'same) (build-path path mode)] 426 [(relative-path? root) (build-path path root mode)] 427 [else (reroot-path (build-path path mode) root)])) 428 (and (directory-exists? compiled-dir) 429 compiled-dir)))) 430 431 ;; ---------------------------------------- 432 (define main-db-file (build-path (find-doc-dir) "docindex.sqlite")) 433 (define user-db-file (build-path (find-user-doc-dir) "docindex.sqlite")) 434 (define (register-or-check-docs check? pkg path main?) 435 (define db-file (if main? main-db-file user-db-file)) 436 (when (file-exists? db-file) 437 (let ([i (get-info/full path #:namespace metadata-ns)]) 438 (define scribblings (if i 439 (i 'scribblings (lambda () null)) 440 null)) 441 (for ([s (in-list scribblings)]) 442 (define src (path->complete-path (car s) path)) 443 (define name (if ((length s) . > . 3) 444 (list-ref s 3) 445 (path-element->string 446 (path-replace-extension (file-name-from-path src) #"")))) 447 (define dest-dir (if main? 448 (build-path (find-doc-dir) name) 449 (build-path path "doc" name))) 450 (cond 451 [check? 452 (for ([dep (in-list (doc-db-get-dependencies (build-path dest-dir "in.sxref") 453 db-file 454 #:attach (if main? 455 #f 456 (and (file-exists? main-db-file) 457 main-db-file))))]) 458 (check-doc! pkg dep dest-dir))] 459 [else 460 (hash-set! doc-pkgs (path->directory-path dest-dir) pkg)]))))) 461 462 (define (register-all-docs!) 463 (define pkg-cache (make-hash)) 464 (define dirs (find-relevant-directories '(scribblings))) 465 (for ([dir (in-list dirs)]) 466 (define-values (pkg subpath scope) (path->pkg+subpath+scope dir #:cache pkg-cache)) 467 (when pkg 468 (define main? (not (eq? scope 'user))) 469 (register-or-check-docs #f pkg dir main?)))) 470 471 ;; ---------------------------------------- 472 473 ;; For each collection, set up package info: 474 (for ([path (in-list paths)] 475 [coll-main? (in-list coll-main?s)]) 476 (define pkg (path->pkg path #:cache path-cache)) 477 (when pkg 478 (init-pkg-internals! pkg) 479 (register-or-check-docs #f pkg path coll-main?))) 480 481 ;; For each collection, check its dependencies: 482 (for ([path (in-list paths)] 483 [coll-path (in-list coll-paths)] 484 [coll-mode (in-list coll-modes)] 485 [coll-main? (in-list coll-main?s)] 486 ;; coll-path is #f for PLaneT packages 487 #:when coll-path) 488 (when verbose? 489 (setup-printf #f " checking ~a" path)) 490 (define dirs (find-compiled-directories path)) 491 (for ([dir (in-list dirs)]) 492 (define pkg (path->pkg path #:cache path-cache)) 493 (when (and pkg 494 (not (hash-ref skip-pkgs pkg #f))) 495 (for ([f (directory-list dir)]) 496 ;; A ".dep" file triggers a check: 497 (when (path-has-extension? f #".dep") 498 ;; Decide whether the file is inherently 'build or 'run mode: 499 (define mode 500 (if (or (eq? coll-mode 'build) 501 (path-has-extension? f #"_scrbl.dep")) 502 'build 503 'run)) 504 ;; Look at the actual module for 'run mode (dropping 505 ;; submodules like `test'): 506 (when (eq? mode 'run) 507 ;; This is the slowest part, because we have to read the module ".zo" 508 (check-bytecode-deps f dir coll-path pkg)) 509 ;; Treat everything in ".dep" as 'build mode... 510 (define deps (cdddr (call-with-input-file* (build-path dir f) read))) 511 (for ([dep (in-list deps)]) 512 (when (and (not (external-dep? dep)) 513 (not (indirect-dep? dep)) 514 (collects-relative-dep? dep)) 515 (define mod (dep->module-path dep)) 516 (check-mod! mod 'build pkg f dir))))) 517 ;; Treat all (direct) documentation links as 'build mode: 518 (register-or-check-docs #t pkg path coll-main?)))) 519 520 ;; check version dependencies: 521 (hash-set! pkg-versions "racket" (version)) 522 (define bad-version-dependencies 523 (for*/fold ([ht #hash()]) ([(pkg deps) (in-hash pkg-version-deps)] 524 [d (in-list deps)]) 525 (define dep-pkg (car d)) 526 (define dep-vers (cdr d)) 527 (define decl-vers (hash-ref pkg-versions dep-pkg "0.0")) 528 (cond 529 [(version<? decl-vers dep-vers) 530 (setup-fprintf* (current-error-port) #f 531 (string-append 532 "package depends on newer version:\n" 533 " package: ~s\n" 534 " depends on package: ~s\n" 535 " depends on version: ~s\n" 536 " current package version: ~s") 537 pkg dep-pkg dep-vers decl-vers) 538 (hash-update ht pkg (lambda (l) (cons d l)) null)] 539 [else ht]))) 540 541 (when check-unused? 542 (for ([(pkg actuals) (in-hash pkg-actual-deps)]) 543 (define availables (hash-ref pkg-internal-deps pkg)) 544 (define unused 545 (for/hash ([actual (in-list actuals)] 546 [available (in-list availables)] 547 [mode '(run build)] 548 #:when #t 549 [i (in-set available)] 550 #:unless (or (equal? i pkg) 551 (equal? i core-pkg) 552 (equal? i 'core) 553 (hash-ref actual i #f) 554 ;; If `i` is implied, then there's a 555 ;; good reason for the dependency. 556 (set-member? (hash-ref pkg-implies pkg (set)) i) 557 ;; If `i' is implied by a package 558 ;; that is used directly, then there's 559 ;; no way around the dependency, so don't 560 ;; report it. 561 (for/or ([a (in-hash-keys actual)]) 562 (set-member? (hash-ref pkg-implies a (set)) i)))) 563 ;; note that 'build override 'run 564 (values i mode))) 565 (unless (zero? (hash-count unused)) 566 (setup-fprintf (current-error-port) #f 567 (apply 568 string-append 569 "unused dependenc~a detected\n" 570 " for package: ~s\n" 571 " on package~a:" 572 (for/list ([(i mode) (in-hash unused)]) 573 (format "\n ~s~a" 574 i 575 (if (eq? mode 'run) 576 " for run" 577 "")))) 578 (if (= (hash-count unused) 1) "y" "ies") 579 pkg 580 (if (= (hash-count unused) 1) "" "s"))))) 581 582 ;; Report result summary and (optionally) repair: 583 (define all-ok? (and (zero? (hash-count missing)) 584 (zero? (hash-count dup-mods)) 585 (zero? (hash-count bad-version-dependencies)) 586 (zero? (hash-count missing-pkgs)))) 587 (unless all-ok? 588 (setup-fprintf (current-error-port) #f 589 (add-time "--- summary of package problems ---")) 590 (for ([(pkg) (in-hash-keys missing-pkgs)]) 591 (setup-fprintf* (current-error-port) #f 592 "package not installed: ~a" 593 pkg)) 594 (for ([(pkg deps) (in-hash bad-version-dependencies)]) 595 (setup-fprintf* (current-error-port) #f 596 (string-append 597 "package depends on newer version:\n" 598 " package: ~s\n" 599 " needed package versions:~a") 600 pkg 601 (apply 602 string-append 603 (for/list ([dep (in-list deps)]) 604 (format "\n ~s version ~s" (car dep) (cdr dep)))))) 605 (for ([pkg (in-list (sort (hash-keys missing) string<?))]) 606 (define pkgs (hash-ref missing pkg)) 607 (define modes '(run build)) 608 (define pkgss (for/list ([mode modes]) 609 (sort 610 (for/list ([(pkg pkg-mode) (in-hash pkgs)] 611 #:when (eq? mode pkg-mode)) 612 (if (eq? pkg 'core) 613 core-pkg 614 pkg)) 615 string<?))) 616 (apply setup-fprintf* (current-error-port) #f 617 (apply 618 string-append 619 "undeclared dependency detected\n" 620 " for package: ~s" 621 (for/list ([pkgs (in-list pkgss)] 622 [mode (in-list modes)] 623 #:when (pair? pkgs)) 624 (format "\n on package~a~a:~~a" 625 (if (null? (cdr pkgs)) "" "s") 626 (case mode 627 [(run) ""] 628 [(build) " for build"])))) 629 pkg 630 (for/list ([pkgs (in-list pkgss)] 631 [mode (in-list modes)] 632 #:when (pair? pkgs)) 633 (apply 634 string-append 635 (for/list ([k (in-list pkgs)]) 636 (format "\n ~s" k))))) 637 (when fix? 638 (define info-path (build-path (pkg-directory pkg #:cache pkg-dir-cache) "info.rkt")) 639 (setup-printf #f "repairing ~s..." info-path) 640 (fix-info-deps-definition info-path 'deps (car pkgss)) 641 (fix-info-deps-definition info-path 'build-deps (cadr pkgss)))) 642 (for ([(mod pkgs) (in-hash dup-mods)]) 643 (setup-fprintf* (current-error-port) #f 644 (string-append 645 "module provided by multiple packages:\n" 646 " module: ~s\n" 647 " providing packages:~a") 648 mod 649 (apply 650 string-append 651 (for/list ([pkg (hash-keys pkgs)]) 652 (format "\n ~s" pkg)))))) 653 all-ok?) 654 655(define (fix-info-deps-definition info-path deps-id pkgs) 656 (unless (null? pkgs) 657 (unless (file-exists? info-path) 658 (call-with-output-file* 659 info-path 660 (lambda (o) 661 (displayln "#lang info" o)))) 662 (define stx (call-with-input-file* 663 info-path 664 (lambda (i) 665 (port-count-lines! i) 666 (with-module-reading-parameterization 667 (lambda () 668 (read-syntax info-path i)))))) 669 (define deps-stx 670 (syntax-case stx () 671 [(mod name lang (#%mb def ...)) 672 (for/or ([def (in-list (syntax->list #'(def ...)))]) 673 (syntax-case def () 674 [(dfn id rhs) 675 (eq? 'define (syntax-e #'dfn)) 676 (and (eq? deps-id (syntax-e #'id)) 677 def)] 678 [_ #f]))] 679 [_ 680 (error 'fix-deps "could not parse ~s" info-path)])) 681 (cond 682 [deps-stx 683 (define (fixup prefix start indent) 684 (unless (and start indent) 685 (error 'fix-deps 686 "could get relevant source location for `~a' definition in ~s" 687 deps-id 688 info-path)) 689 (define str (file->string info-path)) 690 (define new-str 691 (string-append (substring str 0 start) 692 (apply 693 string-append 694 (for/list ([s (in-list pkgs)]) 695 (format "~a~s\n~a" 696 prefix 697 s 698 (make-string indent #\space)))) 699 (substring str start))) 700 (call-with-output-file* 701 info-path 702 #:exists 'truncate 703 (lambda (o) (display new-str o)))) 704 (define (x+ a b) (and a b (+ a b))) 705 (syntax-case deps-stx () 706 [(def id (quot parens)) 707 (and (eq? 'quote (syntax-e #'quot)) 708 (or (null? (syntax-e #'parens)) 709 (pair? (syntax-e #'parens)))) 710 (fixup "" 711 (syntax-position #'parens) 712 (add1 (syntax-column #'parens)))] 713 [(def id (lst . elms)) 714 (eq? 'list (syntax-e #'lst)) 715 (syntax-case deps-stx () 716 [(_ _ parens) 717 (fixup " " 718 (x+ (x+ (syntax-position #'lst) 719 -1) 720 (syntax-span #'lst)) 721 (x+ (syntax-column #'lst) 722 (syntax-span #'lst)))])] 723 [_ 724 (error 'fix-deps 725 "could parse `~a' definition in ~s" 726 deps-id 727 info-path)])] 728 [else 729 (define prefix (format "(define ~a '(" deps-id)) 730 (call-with-output-file* 731 info-path 732 #:exists 'append 733 (lambda (o) 734 (display prefix o) 735 (for ([pkg (in-list pkgs)] 736 [i (in-naturals)]) 737 (unless (zero? i) 738 (newline o) 739 (display (make-string (string-length prefix) #\space) o)) 740 (write pkg o)) 741 (displayln "))" o)))]))) 742