;; Expects parameters to be set before invocation.
;; Calls `exit' when done.

#lang scheme/base

(require scheme/unit
         scheme/path
         scheme/file
         scheme/port
         scheme/match
         scheme/system
         scheme/list
         scheme/string
         compiler/cm
         planet/planet-archives
         planet/private/planet-shared

         "option-sig.rkt"
         compiler/sig
         launcher/launcher-sig

         "unpack.rkt"
         "getinfo.rkt"
         "dirs.rkt"
         "main-collects.rkt"
         "private/path-utils.rkt"
         "private/omitted-paths.rkt")

(define-namespace-anchor anchor)

;; read info files using whatever namespace, .zo-use, and compilation
;;  configuration was in place for loading setup, instead of whatever
;;  is in place for the collections that setup is processing:
(define getinfo
  (let ([ns (namespace-anchor->empty-namespace anchor)]
        [compile (current-compile)]
        [loader (current-load/use-compiled)]
        [paths (use-compiled-file-paths)])
    (lambda (path)
      (parameterize ([current-namespace ns]
                     [current-compile compile]
                     [current-load/use-compiled loader]
                     [use-compiled-file-paths paths])
        (get-info/full path #:namespace ns)))))

(provide setup@)

(define-unit setup@
  (import setup-option^
          compiler^
          (prefix compiler:option: compiler:option^)
          launcher^)
  (export)

  (define name-str (setup-program-name))
  (define name-sym (string->symbol name-str))
  (define main-collects-dir (find-collects-dir))
  (define mode-dir
    (if (compile-mode)
      (build-path "compiled" (compile-mode))
      (build-path "compiled")))

  (define (setup-fprintf p task s . args)
    (let ([task (if task (string-append task ": ") "")])
      (apply fprintf p (string-append name-str ": " task s "\n") args)))

  (define (setup-printf task s . args)
    (apply setup-fprintf (current-output-port) task s args))

  (define (exn->string x) (if (exn? x) (exn-message x) (format "~s" x)))

  ;; auto-curried list-of
  (define list-of
    (case-lambda [(pred) (lambda (x) (and (list? x) (andmap pred x)))]
                 [(pred x) ((list-of pred) x)]))

  (define (relative-path-string? x) (and (path-string? x) (relative-path? x)))


  (define (call-info info flag mk-default test)
    (let ([v (info flag mk-default)]) (test v) v))

  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;;                   Errors                      ;;
  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

  (define errors null)
  (define (record-error cc desc go fail-k)
    (with-handlers ([exn:fail?
                     (lambda (x)
                       (if (verbose)
                           ((error-display-handler)
                            (format "~a\n" (exn->string x))
                            x)
                           (fprintf (current-error-port) "~a\n" (exn->string x)))
                       (set! errors (cons (list cc desc x) errors))
                       (fail-k))])
      (go)))
  (define-syntax begin-record-error
    (syntax-rules ()
      [(_ cc desc body ...) (record-error cc desc (lambda () body ...) void)]))
  (define (show-errors port)
    (for ([e (reverse errors)])
      (match-let ([(list cc desc x) e])
        (setup-fprintf port "error" "during ~a for ~a"
                       desc (if (cc? cc) (cc-name cc) cc))
        (setup-fprintf port #f "  ~a" (exn->string x)))))

  (define (done)
    (setup-printf #f "done")
    (unless (null? errors)
      (setup-printf #f "")
      (show-errors (current-error-port))
      (when (pause-on-errors)
        (fprintf (current-error-port)
                 "INSTALLATION FAILED.\nPress Enter to continue...\n")
        (read-line))
      (exit 1))
    (exit 0))

  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;;               Archive Unpacking               ;;
  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

  (define x-specific-collections
    (append* (specific-collections)
             (for/list ([x (in-list (archives))])
               (unpack x
                       (build-path main-collects-dir 'up)
                       (lambda (s) (setup-printf #f "~a" s))
                       (current-target-directory-getter)
                       (force-unpacks)
                       (current-target-plt-directory-getter)))))

  ;; specific-planet-dir ::=
  ;;    - (list path[directory] string[owner] string[package-name] (listof string[extra package path]) Nat[maj] Nat[min]), or
  ;;    - (list string[owner] string[package-name] string[maj as string] string[min as string])
  ;; x-specific-planet-dir ::= (listof specific-planet-dir)
  (define x-specific-planet-dirs
    (if (make-planet) (specific-planet-dirs) null))

  (define no-specific-collections?
    (and (null? x-specific-collections) (null? x-specific-planet-dirs)))

  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;;              Find Collections                 ;;
  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

  (define-struct cc
    (collection path name info root-dir info-path shadowing-policy)
    #:inspector #f)

  (define (make-cc* collection path root-dir info-path shadowing-policy)
    (define info
      (or (with-handlers ([exn:fail? (warning-handler #f)]) (getinfo path))
          (lambda (flag mk-default) (mk-default))))
    (define name
      (call-info
       info 'name (lambda () #f)
       (lambda (x)
         (when (and x (not (string? x)))
           (error name-sym
                  "'name' result from collection ~e is not a string: ~e"
                  path x)))))
    (define path-name (path->name path))
    (when (info 'compile-subcollections (lambda () #f))
      (setup-printf "WARNING"
                    "ignoring `compile-subcollections' entry in info ~a"
                    path-name))
    ;; this check is also done in compiler/compiler-unit, in compile-directory
    (and (not (eq? 'all (omitted-paths path getinfo)))
         (make-cc collection path
                  (if name (string-append path-name " (" name ")") path-name)
                  info root-dir info-path shadowing-policy)))

  (define ((warning-handler v) exn)
    (setup-printf "WARNING" "~a" (exn->string exn))
    v)

  ;; collection->cc : listof path -> cc/#f
  (define collection->cc-table (make-hash))
  (define (collection->cc collection-p)
    (hash-ref! collection->cc-table collection-p
      (lambda ()
        (define root-dir
          (ormap (lambda (p)
                   (parameterize ([current-library-collection-paths (list p)])
                     (and (with-handlers ([exn:fail? (lambda (x) #f)])
                            (apply collection-path collection-p))
                          p)))
                 (current-library-collection-paths)))
        (make-cc* collection-p
                  (apply collection-path collection-p)
                  root-dir
                  (build-path root-dir "info-domain" "compiled" "cache.rktd")
                  ;; by convention, all collections have "version" 1 0. This
                  ;; forces them to conflict with each other.
                  (list (cons 'lib (map path->string collection-p)) 1 0)))))

  ;; planet-spec->planet-list : (list string string nat nat) -> (list path string string (listof string) nat nat) | #f
  ;; converts a planet package spec into the information needed to create a cc structure
  (define (planet-spec->planet-list spec)
    (match spec
      [(list owner pkg-name maj-str min-str)
       (let ([maj (string->number maj-str)]
             [min (string->number min-str)])
         (unless maj
           (error name-sym "bad major version for PLaneT package: ~e" maj-str))
         (unless min
           (error name-sym "bad minor version for PLaneT package: ~e" min-str))
         (let ([pkg (lookup-package-by-keys owner pkg-name maj min min)])
           (if pkg
             pkg
             (error name-sym "not an installed PLaneT package: (~e ~e ~e ~e)"
                    owner pkg-name maj min))))]
      [_ spec]))

  (define (planet->cc path owner pkg-file extra-path maj min)
    (unless (path? path)
      (error 'planet->cc "non-path when building package ~e" pkg-file))
    (and (directory-exists? path)
         (make-cc* #f
                   path
                   #f ; don't need root-dir; absolute paths in cache.rktd will be ok
                   (get-planet-cache-path)
                   (list `(planet ,owner ,pkg-file ,@extra-path) maj min))))

  ;; planet-cc->sub-cc : cc (listof bytes [encoded path]) -> cc
  ;; builds a compilation job for the given subdirectory of the given cc this
  ;; is an awful hack
  (define (planet-cc->sub-cc cc subdir)
    (match-let ([(list (list 'planet owner pkg-file extra-path ...) maj min)
                 (cc-shadowing-policy cc)])
      (planet->cc (apply build-path (cc-path cc) (map bytes->path subdir))
                  owner
                  pkg-file
                  (append extra-path subdir)
                  maj
                  min)))

  (define all-collections
    (let ([ht (make-hash)])
      (for ([cp (current-library-collection-paths)]
            #:when (directory-exists? cp)
            [collection (directory-list cp)]
            #:when (directory-exists? (build-path cp collection)))
        (hash-ref ht collection
          (lambda ()
            (let ([cc (collection->cc (list collection))])
              (when cc (hash-set! ht collection cc))))))
      (hash-map ht (lambda (k v) v))))

  ;; Close over sub-collections
  (define (collection-closure collections-to-compile make-subs)
    (define (get-subs cc)
      (let* ([info (cc-info cc)]
             [ccp (cc-path cc)]
             ;; note: omit can be 'all, if this happens then this
             ;; collection should not have been included, but we might
             ;; jump in if a command-line argument specified a
             ;; coll/subcoll
             [omit (omitted-paths ccp getinfo)]
             [subs (if (eq? 'all omit)
                     '()
                     (filter (lambda (p)
                               (and (directory-exists? (build-path ccp p))
                                    (not (member p omit))))
                             (directory-list ccp)))])
        (filter values (make-subs cc subs))))
    (filter values
            (let loop ([l collections-to-compile])
              (append-map (lambda (cc) (cons cc (loop (get-subs cc)))) l))))

  (define (plt-collection-closure collections-to-compile)
    (collection-closure
     collections-to-compile
     (lambda (cc subs)
       (map (lambda (sub)
              (collection->cc (append (cc-collection cc) (list sub))))
            subs))))

  (define (check-again-all given-ccs)
    (define (cc->name cc)
      (string-join (map path->string (cc-collection cc)) "/"))
    (define (cc->cc+name+id cc)
      (list cc (cc->name cc) (file-or-directory-identity (cc-path cc))))
    (define all-ccs+names+ids
      (map cc->cc+name+id (plt-collection-closure all-collections)))
    ;; given collections
    (define given-ccs+names+ids (map cc->cc+name+id given-ccs))
    ;; descendants of given collections
    (define descendants-names
      (remove-duplicates
       (append-map
        (lambda (cc)
          (map cc->name (remq cc (plt-collection-closure (list cc)))))
        given-ccs)))
    ;; given collections without duplicates and without ones that are already
    ;; descendants
    (define given*-ccs+names+ids
      (remove-duplicates
       (filter (lambda (cc+name+id)
                 (not (member (cadr cc+name+id) descendants-names)))
               given-ccs+names+ids)
       (lambda (x y) (equal? (cadr x) (cadr y)))))
    ;; check that there are no bad duplicates in the given list
    (for ([given-cc+name+id (in-list given*-ccs+names+ids)])
      (cond
        [(ormap (lambda (cc+name+id)
                  (and (not (equal? (cadr cc+name+id) (cadr given-cc+name+id)))
                       (equal? (caddr cc+name+id) (caddr given-cc+name+id))
                       (cadr cc+name+id)))
                all-ccs+names+ids)
         => (lambda (bad)
              (error name-sym
                     "given collection path: \"~a\" refers to the same directory as another given collection path, \"~a\""
                     (cadr given-cc+name+id) bad))]))
    (map car given*-ccs+names+ids))

  (define (sort-collections ccs)
    (sort ccs string<? #:key cc-name))

  (define ccs-to-compile 
    (let ([planet-dirs-to-compile
            (sort-collections
              (collection-closure
                (if (make-planet)
                  (filter-map (lambda (spec) (apply planet->cc spec))
                              (if no-specific-collections?
                                (get-all-planet-packages)
                                (filter-map planet-spec->planet-list
                                            x-specific-planet-dirs)))
                  null)
                (lambda (cc subs)
                  (map (lambda (p) (planet-cc->sub-cc cc (list (path->bytes p))))
                       subs))))]
          [collections-to-compile
            (sort-collections
             (plt-collection-closure
              (if no-specific-collections?
                all-collections
                (check-again-all
                 (filter-map
                  (lambda (c)
                    (collection->cc (append-map (lambda (s)
                                                  (map string->path
                                                       (regexp-split #rx"/" s)))
                                                c)))
                  x-specific-collections)))))])
    (append collections-to-compile planet-dirs-to-compile)))

  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;;                  Clean                        ;;
  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

  (define (delete-file/record-dependency path dependencies)
    (when (regexp-match-positions #rx"[.]dep$" (path->bytes path))
      (let ([deps (with-handlers ([exn:fail? (lambda (x) null)])
                    (with-input-from-file path read))])
        (when (and (pair? deps) (list? deps))
          (for ([s (in-list (cddr deps))])
            (unless (and (pair? s)
                         (eq? 'ext (car s)))
              (let ([s (main-collects-relative->path s)])
                (when (path-string? s)
                  (hash-set! dependencies s #t))))))))
    (delete-file path))

  (define (delete-files-in-directory path printout dependencies)
    (for ([end-path (directory-list path)])
      (let ([path (build-path path end-path)])
        (cond [(directory-exists? path)
               (void)]
              [(file-exists? path)
               (printout)
               (delete-file/record-dependency path dependencies)]
              [else (error 'delete-files-in-directory
                           "encountered ~a, neither a file nor a directory"
                           path)]))))

  (define (clean-collection cc dependencies)
    (begin-record-error cc "Cleaning"
      (let* ([info (cc-info cc)]
             [paths (call-info
                     info
                     'clean
                     (lambda ()
                       (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
                                "expected a list of path strings for 'clean, got: ~s"
                                x))))]
             [printed? #f]
             [print-message
              (lambda ()
                (unless printed?
                  (set! printed? #t)
                  (setup-printf "deleting" "in ~a"
                                (path->name (cc-path cc)))))])
        (for ([path paths])
          (let ([full-path (build-path (cc-path cc) path)])
            (when (or (file-exists? full-path) (directory-exists? full-path))
              (let ([path (find-relative-path (simple-form-path (cc-path cc))
                                              (simple-form-path full-path))])
                (let loop ([path path])
                  (let-values ([(base name dir?) (split-path path)])
                    (cond
                      [(path? base)
                       (loop base)]
                      [(eq? base 'relative)
                       (when (eq? name 'up)
                         (error 'clean
                                "attempted to clean files in ~s which is not a subdirectory of ~s"
                                full-path
                                (cc-path cc)))]
                      [else
                       (error 'clean
                              "attempted to clean files in ~s which is not a subdirectory of ~s"
                              full-path
                              (cc-path cc))]))))
              (cond [(directory-exists? full-path)
                     (delete-files-in-directory full-path print-message dependencies)]
                    [(file-exists? full-path)
                     (delete-file/record-dependency full-path dependencies)
                     (print-message)]
                    [else (void)])))))))

  (define (clean-step)
    (setup-printf #f "--- cleaning collections ---")
    (let ([dependencies (make-hash)])
      ;; Main deletion:
      (for ([cc ccs-to-compile]) (clean-collection cc dependencies))
      ;; Unless specific collections were named, also
      ;;  delete .zos for referenced modules and delete
      ;;  info-domain cache
      (when no-specific-collections?
        (setup-printf #f "checking dependencies")
        (let loop ([old-dependencies dependencies])
          (let ([dependencies (make-hash)]
                [did-something? #f])
            (hash-for-each
             old-dependencies
             (lambda (file _)
               (let-values ([(dir name dir?) (split-path file)])
                 (let* ([zo (build-path dir mode-dir (path-add-suffix name #".zo"))]
                        [dep (build-path dir mode-dir (path-add-suffix name #".dep"))])
                   (when (and (file-exists? dep) (file-exists? zo))
                     (set! did-something? #t)
                     (setup-printf "deleting" "~a" (path->name zo))
                     (delete-file/record-dependency zo dependencies)
                     (delete-file/record-dependency dep dependencies))))))
            (when did-something? (loop dependencies))))
        (setup-printf #f "clearing info-domain caches")
        (for ([p (current-library-collection-paths)])
          (let ([fn (build-path p "info-domain" "compiled" "cache.rktd")])
            (when (file-exists? fn)
              (with-handlers ([exn:fail:filesystem? (warning-handler (void))])
                (with-output-to-file fn void #:exists 'truncate/replace))))))))

  (define (do-install-part part)
    (when (if (eq? part 'post) (call-post-install) (call-install))
      (setup-printf #f (format "--- ~ainstalling collections ---"
                               (case part
                                 [(pre) "pre-"]
                                 [(general) ""]
                                 [(post) "post-"])))
      (for ([cc ccs-to-compile])
        (let/ec k
          (begin-record-error cc (case part
                                   [(pre)     "Early Install"]
                                   [(general) "General Install"]
                                   [(post)    "Post Install"])
            (let ([fn (call-info (cc-info cc)
                        (case part
                          [(pre)     'pre-install-collection]
                          [(general) 'install-collection]
                          [(post)    'post-install-collection])
                        (lambda () (k #f))
                        (lambda (v)
                          (unless (relative-path-string? v)
                            (error "result is not a relative path string: " v))
                          (let ([p (build-path (cc-path cc) v)])
                            (unless (file-exists? p)
                              (error "installer file does not exist: " p)))))])
              (let ([installer
                     (with-handlers ([exn:fail?
                                      (lambda (exn)
                                        (error name-sym
                                               "error loading installer: ~a"
                                               (exn->string exn)))])
                       (dynamic-require (build-path (cc-path cc) fn)
                                        (case part
                                          [(pre)     'pre-installer]
                                          [(general) 'installer]
                                          [(post)    'post-installer])))])
                (setup-printf (format "~ainstalling"
                                      (case part
                                        [(pre) "pre-"]
                                        [(post) "post-"]
                                        [else ""]))
                              "~a"
                              (cc-name cc))
                (let ([dir (build-path main-collects-dir 'up)])
                  (if (procedure-arity-includes? installer 2)
                    (installer dir (cc-path cc))
                    (installer dir))))))))))

  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;;                  Make zo                      ;;
  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

  (define-syntax-rule (control-io print-verbose body ...)
    (if (make-verbose)
      (begin 
        body ...)
      (let* ([oop (current-output-port)]
             [dir-table (make-hash)]
             [doing-path (lambda (path)
                           (unless (verbose)
                             (let ([path (normal-case-path (path-only path))])
                               (unless (hash-ref dir-table path #f)
                                 (hash-set! dir-table path #t)
                                 (print-verbose oop path)))))])
        (parameterize ([current-output-port (if (verbose) (current-output-port) (open-output-nowhere))]
                       [compile-notify-handler doing-path])
          body ...))))

  (define (clean-cc dir info)
    ;; Clean up bad .zos:
    (unless (info 'assume-virtual-sources (lambda () #f))
      (let ([c (build-path dir "compiled")])
        (when (directory-exists? c)
          (let ([ok-zo-files
                 (make-immutable-hash
                  (map (lambda (p)
                         (cons (path-add-suffix p #".zo") #t))
                       (append (directory-list dir)
                               (info 'virtual-sources (lambda () null)))))])
            (for ([p (directory-list c)])
              (when (and (regexp-match #rx#".(zo|dep)$" (path-element->bytes p))
                         (not (hash-ref ok-zo-files (path-replace-suffix p #".zo") #f)))
                (setup-fprintf (current-error-port) #f " deleting ~a" (build-path c p))
                (delete-file (build-path c p)))))))))

  (define (compile-cc cc)
    (define compile-skip-directory
      (and (avoid-main-installation)
           (find-collects-dir)))
    (let ([dir (cc-path cc)]
          [info (cc-info cc)])
      (clean-cc dir info)
      (compile-directory-zos dir info 
                             #:skip-path compile-skip-directory 
                             #:skip-doc-sources? (not (make-docs)))))

  (define-syntax-rule (with-specified-mode body ...)
    (let ([thunk (lambda () body ...)])
      (if (not (compile-mode))
        (thunk)
        ;; Use the indicated mode
        (let ([zo-compile
               (with-handlers ([exn:fail?
                                (lambda (exn)
                                  (error name-sym
                                         "error loading compiler for mode ~s: ~a"
                                         (compile-mode)
                                         (exn->string exn)))])
                 (dynamic-require `(lib "zo-compile.rkt" ,(compile-mode))
                                  'zo-compile))]
              [orig-kinds (use-compiled-file-paths)]
              [orig-compile (current-compile)]
              [orig-namespace (namespace-anchor->empty-namespace anchor)])
          (parameterize ([current-namespace (make-base-empty-namespace)]
                         [current-compile zo-compile]
                         [use-compiled-file-paths (list mode-dir)]
                         [current-compiler-dynamic-require-wrapper
                          (lambda (thunk)
                            (parameterize ([current-namespace orig-namespace]
                                           [use-compiled-file-paths orig-kinds]
                                           [current-compile orig-compile])
                              (thunk)))])
            (thunk))))))

  ;; To avoid polluting the compilation with modules that are already loaded,
  ;; create a fresh namespace before calling this function.
  ;; To avoid keeping modules in memory across collections, pass
  ;; `make-base-namespace' as `get-namespace', otherwise use
  ;; `current-namespace' for `get-namespace'.
  (define (make-zo-step)
    (setup-printf #f "--- compiling collections ---")
    (with-specified-mode
      (let ([gcs 0])
        (for ([cc ccs-to-compile])
          (parameterize ([current-namespace (make-base-empty-namespace)])
            (begin-record-error cc "making"
              (setup-printf "making" "~a" (cc-name cc))
              (control-io
                (lambda (p where) 
                  (set! gcs 2) 
                  (setup-fprintf p #f " in ~a" (path->name (path->complete-path where (cc-path cc)))))
                (compile-cc cc))))
          (unless (zero? gcs)
            (set! gcs (sub1 gcs))
            (collect-garbage))))))
    

  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;;               Info-Domain Cache               ;;
  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

  (define (make-info-domain-step)
    (setup-printf #f "--- updating info-domain tables ---")
    ;; Each ht maps a collection root dir to an info-domain table. Even when
    ;; `collections-to-compile' is a subset of all collections, we only care
    ;; about those collections that exist in the same root as the ones in
    ;; `collections-to-compile'.
    (let ([ht (make-hash)]
          [ht-orig (make-hash)])
      (for ([cc ccs-to-compile])
        (let* ([domain (with-handlers ([exn:fail? (lambda (x) (lambda () null))])
                         (dynamic-require
                          (build-path (cc-path cc) "info.rkt")
                          '#%info-domain))]
               ;; Check whether we have a table for this cc's info-domain cache:
               [t (hash-ref ht (cc-info-path cc)
                    (lambda ()
                      ;; No table for this root, yet. Build one.
                      (let ([l (let ([p (cc-info-path cc)])
                                 (if (file-exists? p)
                                   (with-handlers ([exn:fail?
                                                    (warning-handler null)])
                                     (with-input-from-file p read))
                                   null))])
                        ;; Convert list to hash table. Incluse only well-formed
                        ;; list elements, and only elements whose corresponding
                        ;; collection exists.
                        (let ([t (make-hash)]
                              [all-ok? #f])
                          (when (list? l)
                            (set! all-ok? #t)
                            (for ([i l])
                              (match i
                                [(list
                                  (? (lambda (a)
                                       (and (bytes? a)
                                            (let ([p (bytes->path a)])
                                              ;; If we have a root directory,
                                              ;; then the path must be relative
                                              ;; to it, otherwise it must be
                                              ;; absolute:
                                              (and (if (cc-root-dir cc)
                                                     (relative-path? p)
                                                     (complete-path? p))
                                                   (file-exists?
                                                    (build-path
                                                     (if (cc-root-dir cc)
                                                       (build-path (cc-root-dir cc) p)
                                                       p)
                                                     "info.rkt"))))))
                                     a)
                                  (list (? symbol? b) ...)
                                  c
                                  (? integer? d)
                                  (? integer? e))
                                 (hash-set! t a (list b c d e))]
                                [_ (set! all-ok? #f)])))
                          ;; Record the table loaded for this collection root
                          ;; in the all-roots table:
                          (hash-set! ht (cc-info-path cc) t)
                          ;; If anything in the "cache.rktd" file was bad, then
                          ;; claim that the old table was empty, so that we
                          ;; definitely write the new table.
                          (hash-set! ht-orig (cc-info-path cc)
                                     (and all-ok? (hash-copy t)))
                          t))))])
          ;; Add this collection's info to the table, replacing any information
          ;; already there.
          (hash-set! t
                     (path->bytes (if (cc-root-dir cc)
                                      ;; Use relative path:
                                      (apply build-path (cc-collection cc))
                                      ;; Use absolute path:
                                      (cc-path cc)))
                     (cons (domain) (cc-shadowing-policy cc)))))
      ;; Write out each collection-root-specific table to a "cache.rktd" file:
      (hash-for-each ht
        (lambda (info-path ht)
          (unless (equal? ht (hash-ref ht-orig info-path))
            (let-values ([(base name must-be-dir?) (split-path info-path)])
              (unless (path? base)
                (error 'make-info-domain
                       "Internal error: cc had invalid info-path: ~e"
                       info-path))
              (make-directory* base)
              (let ([p info-path])
                (setup-printf "updating" "~a" (path->name p))
                (with-handlers ([exn:fail? (warning-handler (void))])
                  (with-output-to-file p
                    #:exists 'truncate/replace
                    (lambda ()
                      (write (hash-map ht cons))
                      (newline)))))))))))

  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;;                       Docs                    ;;
  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

  (define (scr:call name . xs)
    (parameterize ([current-namespace
                    (namespace-anchor->empty-namespace anchor)])
      (apply (dynamic-require 'setup/scribble name) xs)))

  (define (set-doc:verbose)
    (scr:call 'verbose (verbose)))

  (define (doc:setup-scribblings latex-dest auto-start-doc?)
    (scr:call 'setup-scribblings
              (if no-specific-collections? #f (map cc-path ccs-to-compile))
              latex-dest auto-start-doc? (make-user)
              (lambda (what go alt) (record-error what "Building docs" go alt))
              setup-printf))

  (define (make-docs-step)
    (setup-printf #f "--- building documentation ---")
    (set-doc:verbose)
    (with-handlers ([exn:fail?
                     (lambda (exn)
                       (setup-printf #f "docs failure: ~a" (exn->string exn)))])
      (doc:setup-scribblings #f (and (not (null? (archives)))
                                     (archive-implies-reindex)))))

  (define (doc-pdf-dest-step)
    (setup-printf #f "--- building PDF documentation (via pdflatex) ---")
    (let ([dest-dir (path->complete-path (doc-pdf-dest))])
      (unless (directory-exists? dest-dir)
        (make-directory dest-dir))
      (let ([tmp-dir (build-path (find-system-path 'temp-dir)
                                 (format "pltpdfdoc~a" (current-seconds)))])
        (dynamic-wind
          void
          (lambda ()
            (make-directory tmp-dir)
            (set-doc:verbose)
            (doc:setup-scribblings tmp-dir #f)
            (parameterize ([current-directory tmp-dir])
              (for ([f (directory-list)]
                    #:when (regexp-match? #rx#"[.]tex$" (path-element->bytes f)))
                (let* ([pdf (scr:call 'run-pdflatex f
                                      (lambda (fmt . xs)
                                        (apply setup-printf #f fmt xs)))]
                       [target (build-path dest-dir pdf)])
                  (when (file-exists? target) (delete-file target))
                  (copy-file pdf target)))))
          (lambda ()
            (when (directory-exists? tmp-dir)
              (delete-directory/files tmp-dir)))))))

  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;;                  Make Launchers               ;;
  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

  (define (make-launchers-step)
    (setup-printf #f "--- creating launchers ---")
    (let ([name-list
           (lambda (l)
             (unless (list-of relative-path-string? l)
               (error "result is not a list of relative path strings:" l)))]
          [flags-list
           (lambda (l)
             (unless (list-of (list-of string?) l)
               (error "result is not a list of strings:" l)))]
          [or-f (lambda (f) (lambda (x) (when x (f x))))])
      (for ([cc ccs-to-compile])
        (begin-record-error cc "Launcher Setup"
          (define info (cc-info cc))
          (define (make-launcher kind
                                 launcher-names
                                 launcher-libraries
                                 launcher-flags
                                 program-launcher-path
                                 make-launcher
                                 up-to-date?)
            (define mzlns
              (call-info info launcher-names (lambda () null) name-list))
            (define mzlls
              (call-info info launcher-libraries (lambda () #f) (or-f name-list)))
            (define mzlfs
              (call-info info launcher-flags (lambda () #f) (or-f flags-list)))
            (cond
              [(null? mzlns) (void)]
              [(not (or mzlls mzlfs))
               (unless (null? mzlns)
                 (setup-printf
                  "WARNING"
                  "~s launcher name list ~s has no matching library/flags lists"
                  kind mzlns))]
              [(and (or (not mzlls) (= (length mzlns) (length mzlls)))
                    (or (not mzlfs) (= (length mzlns) (length mzlfs))))
               (for ([mzln (in-list mzlns)]
                     [mzll (in-list (or mzlls (map (lambda (_) #f) mzlns)))]
                     [mzlf (in-list (or mzlfs (map (lambda (_) #f) mzlns)))])
                 (let ([p (program-launcher-path mzln)]
                       [aux (list* `(exe-name . ,mzln)
                                   '(framework-root . #f)
                                   '(dll-dir . #f)
                                   `(relative? . ,(not absolute-installation?))
                                   (build-aux-from-path
                                    (build-path (cc-path cc)
                                                (path-replace-suffix
                                                 (or mzll mzln)
                                                 #""))))])
                   (unless (up-to-date? p aux)
                     (setup-printf
                      "launcher"
                      "~a~a"
                      (path->name p #:prefix (format "~a-bin" kind)
                                    #:base (if (equal? kind 'console)
                                             find-console-bin-dir
                                             find-gui-bin-dir))
                      (let ([v (current-launcher-variant)])
                        (if (eq? v (system-type 'gc)) "" (format " [~a]" v))))
                     (make-launcher
                      (or mzlf
                          (if (cc-collection cc)
                            (list "-l-" (string-append
                                         (string-append*
                                          (map (lambda (s) (format "~a/" s))
                                               (cc-collection cc)))
                                         mzll))
                            (list "-t-" (path->string (build-path (cc-path cc) mzll)))))
                      p
                      aux))))]
              [else
               (let ([fault (if (or (not mzlls)
                                    (= (length mzlns) (length mzlls)))
                              'f 'l)])
                 (setup-printf
                  "WARNING"
                  "~s launcher name list ~s doesn't match ~a list; ~s"
                  kind mzlns
                  (if (eq? 'l fault) "library" "flags")
                  (if (eq? fault 'l) mzlls mzlfs)))]))
          (for ([variant (available-gracket-variants)])
            (parameterize ([current-launcher-variant variant])
              (make-launcher 'gui
                             'gracket-launcher-names
                             'gracket-launcher-libraries
                             'gracket-launcher-flags
                             gracket-program-launcher-path
                             make-gracket-launcher
                             gracket-launcher-up-to-date?)
              (make-launcher 'gui
                             'mred-launcher-names
                             'mred-launcher-libraries
                             'mred-launcher-flags
                             mred-program-launcher-path
                             make-mred-launcher
                             mred-launcher-up-to-date?)))
          (for ([variant (available-racket-variants)])
            (parameterize ([current-launcher-variant variant])
              (make-launcher 'console
                             'racket-launcher-names
                             'racket-launcher-libraries
                             'racket-launcher-flags
                             racket-program-launcher-path
                             make-racket-launcher
                             racket-launcher-up-to-date?)
              (make-launcher 'console
                             'mzscheme-launcher-names
                             'mzscheme-launcher-libraries
                             'mzscheme-launcher-flags
                             mzscheme-program-launcher-path
                             make-mzscheme-launcher
                             mzscheme-launcher-up-to-date?)))))))

  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;; setup-unit Body                ;;
  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

  (unless (make-user)
    (current-library-collection-paths
     (if (member main-collects-dir (current-library-collection-paths))
       (list main-collects-dir)
       '())))

  (current-library-collection-paths
   (map simple-form-path (current-library-collection-paths)))

  (setup-printf "version" "~a [~a]" (version) (system-type 'gc))
  (setup-printf "variants" "~a" (string-join (map symbol->string (available-mzscheme-variants)) ", "))
  (setup-printf "main collects" "~a" (path->string main-collects-dir))
  (setup-printf "collects paths" (if (null? (current-library-collection-paths)) " empty!" ""))
  (for ([p (current-library-collection-paths)])
    (setup-printf #f "  ~a" (path->string p)))

  (when (and (not (null? (archives))) no-specific-collections?)
    (done))

  (when (clean) (clean-step))
  (when (make-zo)
    (compiler:option:verbose (compiler-verbose))
    (compiler:option:compile-subcollections #f))

  (do-install-part 'pre)

  (when (make-zo) (make-zo-step))
  (when (make-info-domain) (make-info-domain-step))

  (when (make-launchers) (make-launchers-step))

  (when (make-docs)
    ;; Double-check that "setup/scribble" is present.
    (when (file-exists? (build-path (collection-path "setup") "scribble.rkt"))
      (make-docs-step)))
  (when (doc-pdf-dest) (doc-pdf-dest-step))

  (do-install-part 'general)
  (do-install-part 'post)

  (done))