8bed64f44f
So far, bytecode for traditional Racket has been kept separate from RacketCS bytecode by using a different "compiled" subdirectory for RacketCS. That makes sense for development work to allow the implementations to coexist, but it creates trouble for packaging and distributions, and it (hopefully) won't seem necessary in the long run. Treating the different virtual machines like different versions seems more generally in line with our current infrastructure.
2080 lines
92 KiB
Racket
2080 lines
92 KiB
Racket
;; Expects parameters to be set before invocation.
|
|
;; Calls `exit' when done.
|
|
|
|
#lang racket/base
|
|
|
|
(require racket/path
|
|
racket/file
|
|
racket/port
|
|
racket/match
|
|
racket/system
|
|
racket/list
|
|
racket/string
|
|
compiler/cm
|
|
compiler/compilation-path
|
|
planet/planet-archives
|
|
planet/private/planet-shared
|
|
(only-in planet/resolver resolve-planet-path)
|
|
setup/cross-system
|
|
|
|
"option.rkt"
|
|
compiler/compiler
|
|
(prefix-in compiler:option: compiler/option)
|
|
launcher/launcher
|
|
compiler/module-suffix
|
|
|
|
"unpack.rkt"
|
|
"getinfo.rkt"
|
|
"dirs.rkt"
|
|
"matching-platform.rkt"
|
|
"main-collects.rkt"
|
|
"path-to-relative.rkt"
|
|
"path-relativize.rkt"
|
|
"private/omitted-paths.rkt"
|
|
"parallel-build.rkt"
|
|
"private/cc-struct.rkt"
|
|
"link.rkt"
|
|
"private/dylib.rkt"
|
|
"private/elf.rkt"
|
|
"private/pkg-deps.rkt"
|
|
"collection-name.rkt"
|
|
"private/format-error.rkt"
|
|
"private/encode-relative.rkt"
|
|
compiler/private/dep
|
|
(only-in pkg/lib pkg-directory
|
|
pkg-single-collection))
|
|
|
|
(define-namespace-anchor anchor)
|
|
|
|
;; Although we use `#:bootstrap?' mode for reading an "info.rkt" file,
|
|
;; which disables the use of compiled bytecode, also use whatever
|
|
;; namespace, .zo-use, and compilation configuration was in place for
|
|
;; loading setup (just in case), instead of whatever is in place for
|
|
;; the collections that setup is processing:
|
|
(define make-getinfo
|
|
(let ([ns (namespace-anchor->empty-namespace anchor)]
|
|
[compile (current-compile)]
|
|
[loader (current-load/use-compiled)]
|
|
[paths (use-compiled-file-paths)])
|
|
(lambda (info-ns)
|
|
(lambda (path)
|
|
(parameterize ([current-namespace ns]
|
|
[current-compile compile]
|
|
[current-load/use-compiled loader]
|
|
[use-compiled-file-paths paths])
|
|
(get-info/full path
|
|
#:namespace info-ns
|
|
#:bootstrap? #t))))))
|
|
|
|
(provide setup-core)
|
|
|
|
(define (setup-core)
|
|
|
|
(define name-str (setup-program-name))
|
|
(define name-sym (string->symbol name-str))
|
|
(define main-collects-dir (simple-form-path (find-collects-dir)))
|
|
(define main-collects-dirs (for/hash ([p (in-list (get-main-collects-search-dirs))])
|
|
(values (simple-form-path p) #t)))
|
|
(define main-links-files (for/hash ([p (in-list (get-links-search-files))])
|
|
(values (simple-form-path p) #t)))
|
|
|
|
(define mode-dir
|
|
(let ([compiled-dir (let ([l (or (setup-compiled-file-paths)
|
|
(use-compiled-file-paths))])
|
|
(if (pair? l)
|
|
(car l)
|
|
"compiled"))])
|
|
(if (compile-mode)
|
|
(build-path compiled-dir (compile-mode))
|
|
(build-path compiled-dir))))
|
|
|
|
(unless (make-user)
|
|
(current-library-collection-paths
|
|
(for/list ([p (current-library-collection-paths)]
|
|
#:when (hash-ref main-collects-dirs p #f))
|
|
p)))
|
|
|
|
(current-library-collection-paths
|
|
(if (member #f (current-library-collection-links))
|
|
;; Normal case, include current library collection paths:
|
|
(map simple-form-path (current-library-collection-paths))
|
|
;; No `#f' in links list means that we don't look at
|
|
;; the current library collection paths:
|
|
null))
|
|
|
|
(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)
|
|
(flush-output p)))
|
|
|
|
(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))
|
|
|
|
(define path->relative-string/console-bin
|
|
(make-path->relative-string
|
|
(list (cons find-console-bin-dir "<console-bin>/"))))
|
|
(define path->relative-string/gui-bin
|
|
(make-path->relative-string
|
|
(list (cons find-gui-bin-dir "<gui-bin>/"))))
|
|
|
|
(define path->relative-string/lib
|
|
(make-path->relative-string
|
|
(list (cons find-lib-dir "<lib>/"))))
|
|
|
|
(define path->relative-string/share
|
|
(make-path->relative-string
|
|
(list (cons find-share-dir "<share>/"))))
|
|
|
|
(define path->relative-string/man
|
|
(make-path->relative-string
|
|
(list (cons find-man-dir "<man>/"))))
|
|
|
|
(define-values (path->main-lib-relative
|
|
main-lib-relative->path)
|
|
(make-relativize find-lib-dir
|
|
'lib
|
|
'path->main-lib-relative
|
|
'main-lib-relative->path))
|
|
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Errors ;;
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define errors null)
|
|
(define exit-code 0)
|
|
(define original-thread (current-thread))
|
|
(define (append-error cc desc exn out err type)
|
|
(set! errors (cons (list cc desc exn out err type) errors))
|
|
(when (fail-fast)
|
|
(break-thread original-thread)))
|
|
(define (handle-error cc desc exn out err type)
|
|
(define long? #t) ; possibly better: (define long? (verbose))
|
|
(cond
|
|
[(exn? exn)
|
|
(format-error exn #:long? long?)]
|
|
[(and (pair? exn) (string? (car exn)) (string? (cdr exn)))
|
|
(eprintf "~a\n" ((if long? car cdr) exn))])
|
|
(append-error cc desc exn out err type))
|
|
(define (record-error cc desc go fail-k)
|
|
(with-handlers ([exn:fail?
|
|
(lambda (x)
|
|
(handle-error cc desc x "" "" "error")
|
|
(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 out err type) e])
|
|
(setup-fprintf port type "during ~a for ~a" desc (cond
|
|
[(cc? cc) (cc-name cc)]
|
|
[(path? cc)
|
|
(path->relative-string/setup cc #:cache pkg-path-cache)]
|
|
[else cc]))
|
|
(let ([msg (cond
|
|
[(exn? x)
|
|
(format-error x #:long? #f #:to-string? #t #:cache pkg-path-cache)]
|
|
[(not x)
|
|
;; No error; just output
|
|
#f]
|
|
[else
|
|
;; `x` is a pair of strings, long and short forms of the error:
|
|
(cdr x)])])
|
|
(when x
|
|
(for ([str (in-list (regexp-split #rx"\n" msg))])
|
|
(setup-fprintf port #f " ~a" str))))
|
|
(unless (zero? (string-length out)) (eprintf "STDOUT:\n~a=====\n" out))
|
|
(unless (zero? (string-length err)) (eprintf "STDERR:\n~a=====\n" err)))))
|
|
|
|
(define (done)
|
|
(unless (null? errors)
|
|
(setup-printf #f "--- summary of errors ---")
|
|
(show-errors (current-error-port))
|
|
(when (pause-on-errors)
|
|
(eprintf "INSTALLATION FAILED.\nPress Enter to continue...\n")
|
|
(read-line))
|
|
(exit 1))
|
|
(exit exit-code))
|
|
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Archive Unpacking ;;
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define make-docs?
|
|
(and (make-docs)
|
|
;; Double-check that `setup/scribble' is present:
|
|
(let ([p (collection-file-path "scribble.rkt" "setup")])
|
|
(or (file-exists? p)
|
|
(file-exists? (get-compilation-bytecode-file p))))))
|
|
|
|
(define (pkg->collections pkg)
|
|
(define dir (pkg-directory pkg))
|
|
(cond
|
|
[dir
|
|
(define collect (pkg-single-collection dir #:name pkg))
|
|
(if collect
|
|
(list (list collect))
|
|
(for/list ([d (directory-list dir)]
|
|
#:when (and (directory-exists? (build-path dir d))
|
|
(collection-name-element? (path->string d))))
|
|
(list d)))]
|
|
[else
|
|
(error 'pkd->collections
|
|
(string-append "package not found\n"
|
|
" package: ~a")
|
|
pkg)]))
|
|
|
|
(define x-specific-collections
|
|
(append* (specific-collections)
|
|
(apply append
|
|
(map pkg->collections
|
|
(specific-packages)))
|
|
(if (and (make-doc-index)
|
|
make-docs?)
|
|
(append
|
|
(if (not (avoid-main-installation))
|
|
'(("scribblings/main"))
|
|
null)
|
|
(if (make-user)
|
|
'(("scribblings/main/user"))
|
|
null))
|
|
null)
|
|
(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)
|
|
(not (make-only))))
|
|
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Find Collections ;;
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define pkg-path-cache (make-hash))
|
|
|
|
(define info-ns (make-base-namespace))
|
|
(define getinfo (make-getinfo info-ns))
|
|
|
|
(define info-failures (make-hash))
|
|
(define (getinfo/log-failure path)
|
|
(with-handlers ([exn:fail? (lambda (exn)
|
|
(if (hash-ref info-failures path #f)
|
|
#f
|
|
(begin
|
|
(hash-set! info-failures path #t)
|
|
(handle-error path "load of info.rkt" exn "" "" "error")
|
|
#f)))])
|
|
(getinfo path)))
|
|
|
|
(define (make-cc* collection parent path omit-root info-root
|
|
info-path info-path-mode shadowing-policy
|
|
main?)
|
|
(define info
|
|
(or (getinfo/log-failure 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->relative-string/setup path #:cache pkg-path-cache))
|
|
(when (info 'compile-subcollections (lambda () #f))
|
|
(setup-printf "WARNING"
|
|
"ignoring `compile-subcollections' entry in info ~a"
|
|
path-name))
|
|
(make-cc collection path
|
|
(if name
|
|
(format "~a (~a)" path-name name)
|
|
path-name)
|
|
info
|
|
parent
|
|
omit-root
|
|
info-root info-path info-path-mode
|
|
shadowing-policy
|
|
main?))
|
|
|
|
(define ((warning-handler v) exn)
|
|
(setup-printf "WARNING" "~a" (exn->string exn))
|
|
v)
|
|
|
|
;; Maps a collection name to a list of `cc's:
|
|
(define collection-ccs-table (make-hash))
|
|
|
|
;; collection-cc! : listof-path .... -> cc
|
|
(define (collection-cc! collection-p
|
|
#:parent [parent-cc #f]
|
|
#:path [dir (apply collection-path collection-p)]
|
|
#:omit-root [omit-root #f]
|
|
#:info-root [info-root #f]
|
|
#:info-path [info-path #f]
|
|
#:info-path-mode [info-path-mode 'relative]
|
|
#:main? [main? #f])
|
|
(unless (directory-exists? dir)
|
|
(error name-sym "directory: ~e does not exist for collection: ~s"
|
|
dir
|
|
(string-join (map path->string collection-p) "/")))
|
|
(unless info-root
|
|
(error name-sym "cannot find info root for collection: ~s and path: ~e"
|
|
(string-join (map path->string collection-p) "/")
|
|
dir))
|
|
(define new-cc
|
|
(make-cc* collection-p
|
|
parent-cc
|
|
dir
|
|
(if (eq? omit-root 'dir)
|
|
dir
|
|
omit-root) ; #f => `omitted-paths' can reconstruct it
|
|
info-root
|
|
(or info-path
|
|
(build-path info-root "info-domain" "compiled" "cache.rktd"))
|
|
info-path-mode
|
|
;; 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)
|
|
main?))
|
|
(when new-cc
|
|
(hash-update! collection-ccs-table
|
|
collection-p
|
|
(lambda (lst) (cons new-cc lst))
|
|
null))
|
|
new-cc)
|
|
|
|
;; collection->ccs : listof-path -> listof-cc
|
|
(define (collection->ccs collection-p)
|
|
(hash-ref collection-ccs-table collection-p null))
|
|
|
|
;; 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)
|
|
(define maj
|
|
(or (string->number maj-str)
|
|
(error name-sym "bad major version for PLaneT package: ~e" maj-str)))
|
|
(define min
|
|
(or (string->number min-str)
|
|
(error name-sym "bad minor version for PLaneT package: ~e" min-str)))
|
|
(or (lookup-package-by-keys owner pkg-name maj min min)
|
|
(error name-sym "not an installed PLaneT package: (~e ~e ~e ~e)"
|
|
owner pkg-name maj min))]
|
|
[_ spec]))
|
|
|
|
(define (planet-cc! path #:omit-root [omit-root 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
|
|
#f
|
|
path
|
|
omit-root
|
|
#f ; don't need info-root; absolute paths in cache.rktd will be ok
|
|
(get-planet-cache-path)
|
|
'abs
|
|
(list `(planet ,owner ,pkg-file ,@extra-path) maj min)
|
|
#f)))
|
|
|
|
;; 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))
|
|
#:omit-root (cc-omit-root cc)
|
|
owner
|
|
pkg-file
|
|
(append extra-path subdir)
|
|
maj
|
|
min)))
|
|
|
|
(define (skip-collection-directory? collection)
|
|
;; Skiping ".git" or ".svn" makes it cleaner to use a git of subversion
|
|
;; checkout as a collection directory
|
|
(regexp-match? #rx"[.](git|svn)$" (path->bytes collection)))
|
|
|
|
;; Add in all non-planet collections, first from
|
|
;; `current-library-collection-paths':
|
|
(for ([cp (current-library-collection-paths)]
|
|
#:when (directory-exists? cp)
|
|
[collection (directory-list cp)]
|
|
#:unless (skip-collection-directory? collection)
|
|
#:when (directory-exists? (build-path cp collection)))
|
|
(collection-cc! (list collection)
|
|
#:info-root cp
|
|
#:path (build-path cp collection)
|
|
#:main? (hash-ref main-collects-dirs cp #f)))
|
|
;; Now from `current-library-collection-links' for installation-wide
|
|
;; links:
|
|
(let ()
|
|
(define info-root (find-share-dir))
|
|
(define info-path (build-path info-root "info-cache.rktd"))
|
|
(define (cc! col #:path path)
|
|
(collection-cc! col
|
|
#:path path
|
|
#:info-root info-root
|
|
#:info-path info-path
|
|
#:info-path-mode 'abs-in-relative
|
|
#:omit-root 'dir
|
|
#:main? #t))
|
|
(for ([inst-links (in-list (current-library-collection-links))]
|
|
#:when (and (path? inst-links)
|
|
(hash-ref main-links-files (simple-form-path inst-links) #f)))
|
|
(for ([c+p (in-list (links #:file inst-links #:with-path? #t))])
|
|
(cc! (list (string->path (car c+p)))
|
|
#:path (cdr c+p)))
|
|
(for ([cp (in-list (links #:root? #t #:file inst-links))]
|
|
#:when (directory-exists? cp)
|
|
[collection (directory-list cp)]
|
|
#:unless (skip-collection-directory? collection)
|
|
#:when (directory-exists? (build-path cp collection)))
|
|
(cc! (list collection)
|
|
#:path (build-path cp collection)))))
|
|
;; Now from `current-library-collection-links' for user-specific
|
|
;; links:
|
|
(when (make-user)
|
|
(define info-root (find-user-share-dir))
|
|
(define info-path (build-path info-root "info-cache.rktd"))
|
|
(define (cc! col #:path path)
|
|
(collection-cc! col
|
|
#:path path
|
|
#:info-root info-root
|
|
#:info-path info-path
|
|
#:info-path-mode 'abs-in-relative
|
|
#:omit-root 'dir))
|
|
;; A links spec in `current-library-collection-links' counts as
|
|
;; user-specific when it's not in `make-links-files':
|
|
(for ([inst-links (in-list (current-library-collection-links))]
|
|
#:unless (and (path? inst-links)
|
|
(hash-ref main-links-files (simple-form-path inst-links) #f)))
|
|
(cond
|
|
[(not inst-links) ; covered by `current-library-collection-paths'
|
|
(void)]
|
|
[(path? inst-links)
|
|
(for ([c+p (in-list (links #:file inst-links #:with-path? #t))])
|
|
(cc! (list (string->path (car c+p)))
|
|
#:path (cdr c+p)))
|
|
(for ([cp (in-list (links #:file inst-links #:root? #t))]
|
|
#:when (directory-exists? cp)
|
|
[collection (directory-list cp)]
|
|
#:unless (skip-collection-directory? collection)
|
|
#:when (directory-exists? (build-path cp collection)))
|
|
(cc! (list collection) #:path (build-path cp collection)))]
|
|
[else ; must be a hash table that simulates a links file:
|
|
(for ([(coll-sym dir) (in-hash inst-links)])
|
|
(cond
|
|
[coll-sym
|
|
;; A single collection
|
|
(cc! (string-split "/" (symbol->string coll-sym)) #:path dir)]
|
|
[(directory-exists? dir)
|
|
;; A directory that holds collections:
|
|
(for ([collection (directory-list dir)]
|
|
#:unless (skip-collection-directory? collection)
|
|
#:when (directory-exists? (build-path dir collection)))
|
|
(cc! (list collection) #:path (build-path dir collection)))]))])))
|
|
|
|
;; `all-collections' lists all top-level collections (not from Planet):
|
|
(define all-collections
|
|
(apply append (hash-map collection-ccs-table (lambda (k v) v))))
|
|
|
|
;; Close over sub-collections
|
|
(define (collection-closure collections-to-compile make-subs)
|
|
(define (get-subs cc)
|
|
(define info (cc-info cc))
|
|
(define 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
|
|
(define omit (omitted-paths ccp getinfo/log-failure (cc-omit-root cc)))
|
|
(define 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 (collection-tree-map collections-to-compile has-module-suffix?)
|
|
(define (build-collection-tree cc)
|
|
(define (make-child-cc parent-cc name)
|
|
(collection-cc! (append (cc-collection parent-cc) (list name))
|
|
#:parent parent-cc
|
|
#:path (build-path (cc-path parent-cc) name)
|
|
#:info-root (cc-info-root cc)
|
|
#:info-path (cc-info-path cc)
|
|
#:info-path-mode (cc-info-path-mode cc)
|
|
#:omit-root (cc-omit-root cc)
|
|
#:main? (cc-main? cc)))
|
|
(define info (cc-info cc))
|
|
(define 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
|
|
(define omit (let ([omit (omitted-paths ccp getinfo/log-failure (cc-omit-root cc))])
|
|
(if (eq? omit 'all)
|
|
'all
|
|
(append
|
|
(if make-docs?
|
|
null
|
|
(list (string->path "scribblings")))
|
|
omit))))
|
|
(define-values [dirs files]
|
|
(if (eq? 'all omit)
|
|
(values null null)
|
|
(partition (lambda (x) (directory-exists? (build-path ccp x)))
|
|
(filter (lambda (p) (not (member p omit)))
|
|
(directory-list ccp)))))
|
|
(define children-ccs
|
|
(map build-collection-tree
|
|
(filter-map (lambda (x) (make-child-cc cc x)) dirs)))
|
|
(define srcs
|
|
(append
|
|
(filter has-module-suffix? files)
|
|
(if (and make-docs?
|
|
(not (eq? omit 'all)))
|
|
(filter (lambda (p) (not (member p omit)))
|
|
(map (lambda (s) (if (string? s) (string->path s) s))
|
|
(map car
|
|
(let ([v (call-info info 'scribblings (lambda () null) void)])
|
|
;; Ignore ill-formed 'scribblings entries at this level:
|
|
(if (list? v)
|
|
(for/list ([i (in-list v)]
|
|
#:when (and (pair? i)
|
|
(string? (car i))))
|
|
i)
|
|
null)))))
|
|
null)
|
|
(map (lambda (s) (if (string? s) (string->path s) s))
|
|
(call-info info 'compile-include-files (lambda () null) void))))
|
|
(list cc srcs children-ccs))
|
|
(map build-collection-tree collections-to-compile))
|
|
|
|
(define (plt-collection-closure collections-to-compile)
|
|
(define (make-children-ccs cc children)
|
|
(map (lambda (child)
|
|
(collection-cc! (append (cc-collection cc) (list child))
|
|
#:parent cc
|
|
#:path (build-path (cc-path cc) child)
|
|
#:info-root (cc-info-root cc)
|
|
#:info-path (cc-info-path cc)
|
|
#:info-path-mode (cc-info-path-mode cc)
|
|
#:omit-root (cc-omit-root cc)
|
|
#:main? (cc-main? cc)))
|
|
children))
|
|
(collection-closure collections-to-compile make-children-ccs))
|
|
|
|
(define (lookup-collection-closure collections-to-compile)
|
|
(define ht (make-hash))
|
|
(for ([cc (in-list collections-to-compile)])
|
|
(hash-set! ht cc #t))
|
|
(define (lookup-children-ccs! cc children)
|
|
(apply
|
|
append
|
|
(for/list ([child (in-list children)])
|
|
(for/list ([cc (in-list (collection->ccs (append (cc-collection cc) (list child))))]
|
|
#:unless (hash-ref ht cc #f))
|
|
(hash-set! ht cc #t)
|
|
cc))))
|
|
(collection-closure collections-to-compile lookup-children-ccs!)
|
|
(for/list ([v (in-hash-keys ht)]) v))
|
|
|
|
(define all-collections-closure (plt-collection-closure all-collections))
|
|
|
|
(define (check-against-all given-ccs nothing-else-to-do?)
|
|
(when (and (null? given-ccs)
|
|
nothing-else-to-do?
|
|
(not (make-tidy)))
|
|
(setup-printf #f "nothing to do")
|
|
(exit 0))
|
|
(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 all-collections-closure))
|
|
;; 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 (lookup-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)
|
|
(and (equal? (cadr x) (cadr y))
|
|
(equal? (cc-path (car x)) (cc-path (car y)))))))
|
|
;; check that there are no bad duplicates in the given list
|
|
(for ([given-cc+name+id (in-list given*-ccs+names+ids)])
|
|
(define bad
|
|
(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))
|
|
(when 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 (sort-collections-tree ccs)
|
|
(sort ccs string<? #:key (lambda (x) (cc-name (first x)))))
|
|
|
|
(define planet-collects
|
|
(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))
|
|
|
|
(define all-top-level-plt-collects
|
|
(if no-specific-collections?
|
|
all-collections
|
|
(check-against-all
|
|
(append-map
|
|
(lambda (c)
|
|
(define sc (map (lambda (s) (if (path? s) (path->string s) s))
|
|
c))
|
|
(define elems
|
|
(append-map (lambda (s) (map string->path (regexp-split #rx"/" s)))
|
|
sc))
|
|
(define ccs (collection->ccs elems))
|
|
(when (null? ccs)
|
|
;; let `collection-path' complain about the name, if that's the problem:
|
|
(with-handlers ([exn? (compose1 raise-user-error exn-message)])
|
|
(apply collection-path elems))
|
|
;; otherwise, it's probably a collection with nothing to compile;
|
|
;; spell the name
|
|
(setup-printf "warning"
|
|
"nothing to compile in a given collection path: \"~a\""
|
|
(string-join sc "/")))
|
|
ccs)
|
|
x-specific-collections)
|
|
(null? planet-collects))))
|
|
|
|
(define top-level-plt-collects
|
|
(if (avoid-main-installation)
|
|
(filter (lambda (cc) (not (cc-main? cc)))
|
|
all-top-level-plt-collects)
|
|
all-top-level-plt-collects))
|
|
|
|
(define planet-dirs-to-compile
|
|
(sort-collections
|
|
(collection-closure
|
|
planet-collects
|
|
(lambda (cc subs)
|
|
(map (lambda (p) (planet-cc->sub-cc cc (list (path->bytes p))))
|
|
subs)))))
|
|
|
|
(define (combine-collections top-level-plt-collects)
|
|
(append
|
|
(sort-collections (lookup-collection-closure top-level-plt-collects))
|
|
planet-dirs-to-compile))
|
|
|
|
(define ccs-to-compile
|
|
(combine-collections top-level-plt-collects))
|
|
|
|
(define ccs-to-call-installers
|
|
(if (avoid-main-installation)
|
|
;; Although we mostly avoid the main installation, we'll
|
|
;; need to call main-installaiton launchers in case they
|
|
;; support being called to perform only user-specific
|
|
;; actions.
|
|
(combine-collections all-top-level-plt-collects)
|
|
ccs-to-compile))
|
|
|
|
(define ccs-to-make-launchers
|
|
(if (or (find-addon-tethered-console-bin-dir)
|
|
(find-addon-tethered-gui-bin-dir))
|
|
ccs-to-call-installers
|
|
ccs-to-compile))
|
|
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Clean ;;
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define (delete-file/record-dependency path dependencies)
|
|
(when (path-has-extension? path #".dep")
|
|
(define deps
|
|
(with-handlers ([exn:fail? (lambda (x) null)])
|
|
(with-input-from-file path read)))
|
|
(when (and (pair? deps) (list? deps))
|
|
(for ([s (in-list (cdddr deps))])
|
|
(unless (external-dep? s)
|
|
(define new-s (dep->path s))
|
|
(when (path-string? new-s) (hash-set! dependencies new-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 (assume-virtual-sources? cc)
|
|
(or ((cc-info cc) 'assume-virtual-sources (lambda () #f))
|
|
(let ([cc (cc-parent-cc cc)])
|
|
(and cc
|
|
(assume-virtual-sources? cc)))))
|
|
|
|
(define (clean-collection cc dependencies)
|
|
(begin-record-error cc "cleaning"
|
|
(define info (cc-info cc))
|
|
(define paths
|
|
(call-info
|
|
info
|
|
'clean
|
|
(lambda ()
|
|
(if (assume-virtual-sources? cc)
|
|
null
|
|
(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)))))
|
|
(define printed? #f)
|
|
(define (print-message)
|
|
(unless printed?
|
|
(set! printed? #t)
|
|
(setup-printf "deleting" "in ~a"
|
|
(path->relative-string/setup (cc-path cc)
|
|
#:cache pkg-path-cache))))
|
|
(for ([path paths])
|
|
(define full-path (build-path (cc-path cc) path))
|
|
(when (or (file-exists? full-path) (directory-exists? full-path))
|
|
(let loop ([path (find-relative-path (simple-form-path (cc-path cc))
|
|
(simple-form-path full-path))])
|
|
(define-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 ---")
|
|
(define 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])
|
|
(define dependencies (make-hash))
|
|
(define did-something? #f)
|
|
(hash-for-each
|
|
old-dependencies
|
|
(lambda (file _)
|
|
(define-values [dir name dir?] (split-path file))
|
|
(define zo (build-path dir mode-dir (path-add-extension name #".zo")))
|
|
(define dep (build-path dir mode-dir (path-add-extension name #".dep")))
|
|
(when (and (file-exists? dep) (file-exists? zo))
|
|
(set! did-something? #t)
|
|
(setup-printf "deleting" "~a" (path->relative-string/setup zo #:cache pkg-path-cache))
|
|
(delete-file/record-dependency zo dependencies)
|
|
(delete-file/record-dependency dep dependencies))))
|
|
(when did-something? (loop dependencies)))
|
|
(when (make-info-domain)
|
|
(setup-printf #f "clearing info-domain caches")
|
|
(define (check-one-info-domain fn)
|
|
(when (file-exists? fn)
|
|
(with-handlers ([exn:fail:filesystem? (warning-handler (void))])
|
|
(with-output-to-file fn void #:exists 'truncate/replace))))
|
|
(for ([p (current-library-collection-paths)])
|
|
(check-one-info-domain (build-path p "info-domain" "compiled" "cache.rktd")))
|
|
(check-one-info-domain (build-path (find-share-dir) "info-cache.rktd"))
|
|
(check-one-info-domain (build-path (find-user-share-dir) "info-cache.rktd")))
|
|
(when make-docs?
|
|
(setup-printf #f "deleting documentation databases")
|
|
(for ([d (in-list (list (find-doc-dir) (find-user-doc-dir)))])
|
|
(when d
|
|
(define f (build-path d "docindex.sqlite"))
|
|
(when (file-exists? f)
|
|
(delete-file f)))))))
|
|
|
|
(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-call-installers])
|
|
(let/ec k
|
|
(begin-record-error cc (case part
|
|
[(pre) "early install"]
|
|
[(general) "general install"]
|
|
[(post) "post install"])
|
|
(define 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))
|
|
(define p (build-path (cc-path cc) v))
|
|
(unless (or (file-exists? p)
|
|
(bytecode-file-exists? p))
|
|
(error "installer file does not exist: " p)))))
|
|
(define installer
|
|
(with-handlers ([exn:fail?
|
|
(lambda (exn)
|
|
(error name-sym
|
|
"error loading installer: ~a"
|
|
(exn->string exn)))])
|
|
(define base-installer
|
|
(dynamic-require (build-path (cc-path cc) fn)
|
|
(case part
|
|
[(pre) 'pre-installer]
|
|
[(general) 'installer]
|
|
[(post) 'post-installer])))
|
|
(if (and (cc-main? cc)
|
|
(avoid-main-installation)
|
|
(not (procedure-arity-includes? base-installer 4)))
|
|
#f
|
|
base-installer)))
|
|
(when installer
|
|
(setup-printf (format "~ainstalling"
|
|
(case part
|
|
[(pre) "pre-"]
|
|
[(post) "post-"]
|
|
[else ""]))
|
|
"~a"
|
|
(cc-name cc))
|
|
(define dir (build-path main-collects-dir 'up))
|
|
(cond
|
|
[(procedure-arity-includes? installer 4)
|
|
(installer dir (cc-path cc) (not (cc-main? cc)) (and (cc-main? cc)
|
|
(avoid-main-installation)))]
|
|
[(procedure-arity-includes? installer 3)
|
|
(installer dir (cc-path cc) (not (cc-main? cc)))]
|
|
[(procedure-arity-includes? installer 2)
|
|
(installer dir (cc-path cc))]
|
|
[else
|
|
(installer dir)])))))))
|
|
|
|
(define (bytecode-file-exists? p)
|
|
(parameterize ([use-compiled-file-paths (list mode-dir)])
|
|
(define zo (get-compilation-bytecode-file p))
|
|
(file-exists? zo)))
|
|
|
|
(define (this-platform? info)
|
|
(define sys
|
|
(call-info info
|
|
'install-platform
|
|
(lambda () #rx"")
|
|
(lambda (v)
|
|
(unless (or (regexp? v)
|
|
(string? v)
|
|
(symbol? v))
|
|
(error "entry is not regexp, string, or symbol:" v)))))
|
|
(matching-platform? sys #:cross? #t))
|
|
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Make zo ;;
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define (control-io print-verbose thunk)
|
|
(if (make-verbose)
|
|
(thunk)
|
|
(let* ([oop (current-output-port)]
|
|
[dir-table (make-hash)]
|
|
[doing-path (lambda (path)
|
|
(unless (verbose)
|
|
(let ([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])
|
|
(thunk)))))
|
|
|
|
(define (clean-cc cc)
|
|
;; Clean up bad .zos:
|
|
(unless (assume-virtual-sources? cc)
|
|
(define dir (cc-path cc))
|
|
(define info (cc-info cc))
|
|
(define roots
|
|
;; If there's more than one relative root, then there will
|
|
;; be multiple ways to get to a ".zo" file, and our strategy
|
|
;; below will fail. Give up on checking relative roots in
|
|
;; that case.
|
|
(let ([roots (current-compiled-file-roots)])
|
|
(if (1 . < . (for/sum ([r (in-list roots)])
|
|
(if (or (eq? r 'same)
|
|
(relative-path? r))
|
|
1
|
|
0)))
|
|
;; give up on relative:
|
|
(filter (lambda (p) (and (path? p) (absolute-path? p)))
|
|
roots)
|
|
;; all roots ok:
|
|
roots)))
|
|
;; Try each compile-file root, but preserve the list of allowed
|
|
;; bytecode files after it's computed the first time.
|
|
(for/fold ([ok-zo-files #f]) ([root (in-list roots)])
|
|
(define c (cond
|
|
[(eq? root 'same) (build-path dir mode-dir)]
|
|
[(relative-path? root)
|
|
(build-path dir root mode-dir)]
|
|
[else
|
|
(reroot-path (build-path dir mode-dir) root)]))
|
|
(cond
|
|
[(directory-exists? c)
|
|
;; Directory for compiled files exist...
|
|
(let ([ok-zo-files
|
|
(or ok-zo-files
|
|
;; Build table of allowed ".zo" file names that can
|
|
;; appear in a "compiled" directory:
|
|
(make-immutable-hash
|
|
(map (lambda (p)
|
|
(cons (path-add-extension p #".zo") #t))
|
|
(append (directory-list dir)
|
|
(info 'virtual-sources (lambda () null))))))])
|
|
;; Check each file in `c` to see whether it can stay:
|
|
(for ([p (directory-list c)])
|
|
(when (and (regexp-match? #rx#".[.](zo|dep)$" (path-element->bytes p))
|
|
(not (hash-ref ok-zo-files (path-replace-extension p #".zo") #f)))
|
|
(setup-fprintf (current-error-port) #f " deleting ~a" (build-path c p))
|
|
(delete-file (build-path c p))))
|
|
ok-zo-files)]
|
|
[else ok-zo-files]))))
|
|
|
|
(define (with-specified-mode thunk)
|
|
(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)))))
|
|
|
|
;; We keep timestamp information for all files that we try to compile.
|
|
;; That's O(N) for an installation of size N, but the constant is small,
|
|
;; and it makes a do-nothing setup complete much faster.
|
|
(define caching-managed-compile-zo (make-caching-managed-compile-zo))
|
|
|
|
(define (compile-cc cc gcs has-module-suffix?)
|
|
(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->relative-string/setup
|
|
(path->complete-path where (cc-path cc))
|
|
#:cache pkg-path-cache)))
|
|
(lambda ()
|
|
(define dir (cc-path cc))
|
|
(define info (cc-info cc))
|
|
(compile-directory-zos dir info
|
|
#:has-module-suffix? has-module-suffix?
|
|
#:omit-root (cc-omit-root cc)
|
|
#:managed-compile-zo caching-managed-compile-zo
|
|
#:skip-path (and (avoid-main-installation) main-collects-dir)
|
|
#:skip-doc-sources? (not make-docs?))))))
|
|
(if (eq? 0 gcs)
|
|
0
|
|
(begin (collect-garbage) (sub1 gcs))))
|
|
|
|
;; 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 (iterate-cct thunk cct)
|
|
(let loop ([cct cct])
|
|
(map (lambda (x) (thunk (first x)) (loop (third x))) cct)))
|
|
|
|
(define (make-zo-step)
|
|
(define (partition-cct name cct)
|
|
(partition (lambda (x) (not (regexp-match? name (cc-name (car x))))) cct))
|
|
(define (move-to where names cct)
|
|
(for/fold ([cct cct]) ([name (in-list (reverse names))])
|
|
(define-values [diff same] (partition-cct name cct))
|
|
(case where
|
|
[(beginning) (append same diff)]
|
|
[(end) (append diff same)])))
|
|
(define has-module-suffix?
|
|
(let ([rx (get-module-suffix-regexp
|
|
#:mode (cond
|
|
[(make-user) 'preferred]
|
|
[else 'no-user])
|
|
#:group 'libs
|
|
#:namespace info-ns)])
|
|
(lambda (p) (regexp-match? rx p))))
|
|
(setup-printf #f "--- compiling collections ---")
|
|
(if ((parallel-workers) . > . 1)
|
|
(begin
|
|
(when (or no-specific-collections?
|
|
(member "racket" x-specific-collections))
|
|
(for/fold ([gcs 0]) ([cc (in-list (collection->ccs (list (string->path "racket"))))])
|
|
(when (and (cc-main? cc)
|
|
(member (cc-info-root cc)
|
|
(current-library-collection-paths)))
|
|
(compile-cc cc 0 has-module-suffix?))))
|
|
(with-specified-mode
|
|
(lambda ()
|
|
(define cct
|
|
(move-to 'beginning (list #rx"/compiler$" #rx"/raco$" #rx"/racket$" #rx"<pkgs>/images/")
|
|
(move-to 'end (list #rx"<pkgs>/drracket")
|
|
(sort-collections-tree
|
|
(collection-tree-map top-level-plt-collects
|
|
has-module-suffix?)))))
|
|
(iterate-cct clean-cc cct)
|
|
(parallel-compile (parallel-workers) setup-fprintf handle-error cct
|
|
#:use-places? (parallel-use-places))
|
|
(for/fold ([gcs 0]) ([cc planet-dirs-to-compile])
|
|
(compile-cc cc gcs has-module-suffix?)))))
|
|
(with-specified-mode
|
|
(lambda ()
|
|
(for ([cc ccs-to-compile])
|
|
(clean-cc cc))
|
|
(for/fold ([gcs 0]) ([cc ccs-to-compile])
|
|
(compile-cc cc gcs has-module-suffix?))))))
|
|
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; 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'.
|
|
(define ht (make-hash))
|
|
(define ht-orig (make-hash))
|
|
(define roots (make-hash))
|
|
(define (get-info-ht info-root info-path info-path-mode)
|
|
(define-values (path->info-relative info-relative->path)
|
|
(apply values
|
|
(hash-ref roots
|
|
info-root
|
|
(lambda ()
|
|
(define-values [p-> ->p]
|
|
(if info-root
|
|
(make-relativize (lambda () info-root)
|
|
'info
|
|
'path->info-relative
|
|
'info-relative->path)
|
|
(values #f #f)))
|
|
(hash-set! roots info-root (list p-> ->p))
|
|
(list p-> ->p)))))
|
|
(hash-ref ht info-path
|
|
(lambda ()
|
|
;; No table for this root, yet. Build one.
|
|
(define l
|
|
(let ([p info-path])
|
|
(if (file-exists? p)
|
|
(with-handlers ([exn:fail? (warning-handler null)])
|
|
(with-input-from-file p read))
|
|
null)))
|
|
;; Convert list to hash table. Include only well-formed
|
|
;; list elements, and only elements whose corresponding
|
|
;; collection exists.
|
|
(define t (make-hash))
|
|
(define all-ok? #f)
|
|
(when (list? l)
|
|
(set! all-ok? #t)
|
|
(for ([i l])
|
|
(match i
|
|
[(list (and a (or (? bytes?)
|
|
(list (or 'info 'lib) (? bytes?) ...)
|
|
(list 'rel (or 'up (? bytes?)) ...)))
|
|
(list (? symbol? b) ...) c (? integer? d) (? integer? e))
|
|
(define p
|
|
(cond
|
|
[(bytes? a) (bytes->path a)]
|
|
[(and (pair? a) (eq? 'rel (car a)))
|
|
(decode-relative-path a)]
|
|
[else a]))
|
|
(define (normalize-relative-encoding a p)
|
|
(if (and (bytes? a) (relative-path? p))
|
|
;; Convert to encoded form, since new entries will
|
|
;; use encoding to avoid path-convention problems
|
|
;; with cross-compilation:
|
|
(encode-relative-path p)
|
|
a))
|
|
;; Check that the path is suitably absolute or relative:
|
|
(define dir
|
|
(case info-path-mode
|
|
[(relative abs-in-relative)
|
|
(or (and (list? p)
|
|
(if (eq? (car p) 'info)
|
|
(info-relative->path p)
|
|
(main-lib-relative->path p)))
|
|
;; `c' must be `(lib ...)'
|
|
(and (or (relative-path? p)
|
|
;; Keep a complete path only if it could not be
|
|
;; made relative:
|
|
(and (complete-path? p)
|
|
(complete-path?
|
|
(find-relative-path info-root
|
|
p
|
|
#:more-than-root? #t))))
|
|
(list? c)
|
|
(pair? c)
|
|
(eq? 'lib (car c))
|
|
(pair? (cdr c))
|
|
(andmap string? (cdr c))
|
|
(let ([p (simplify-path (path->complete-path p info-root))])
|
|
(and
|
|
;; path must match some cc:
|
|
(for/or ([cc (in-list all-collections-closure)])
|
|
(equal? p (cc-path cc)))
|
|
p))))]
|
|
[(abs)
|
|
(and (complete-path? p)
|
|
(match c
|
|
[(list 'planet (? string? a) (? string? pk))
|
|
;; Check that the package is installed and maps to `p`:
|
|
(and (get-installed-package a pk d e)
|
|
(let ([bp (resolve-planet-path
|
|
`(planet "bogus.rkt" (,a ,pk ,d ,e)))])
|
|
(and (path? bp)
|
|
(let-values ([(base name dir?) (split-path bp)])
|
|
(and (path? base)
|
|
(equal? (path->directory-path p)
|
|
(path->directory-path base)))))))]
|
|
[else
|
|
#t])
|
|
p)]))
|
|
(if (and dir
|
|
(let ([omit-root
|
|
(if (path? p)
|
|
;; absolute path => need a root for checking omits;
|
|
;; for a collection path of length N, go up N-1 dirs:
|
|
(simplify-path (apply build-path p (for/list ([i (cddr c)]) 'up)) #f)
|
|
;; relative path => no root needed for checking omits:
|
|
#f)])
|
|
(and (directory-exists? dir)
|
|
(not (eq? 'all (omitted-paths dir getinfo/log-failure omit-root)))))
|
|
(or (file-exists? (build-path dir "info.rkt"))
|
|
(file-exists? (build-path dir "info.ss"))))
|
|
(hash-set! t (normalize-relative-encoding a p) (list b c d e))
|
|
(begin (when (verbose) (printf " drop entry: ~s\n" i))
|
|
(set! all-ok? #f)))]
|
|
[_ (when (verbose) (printf " bad entry: ~s\n" i))
|
|
(set! all-ok? #f)])))
|
|
;; Record the table loaded for this collection root in the
|
|
;; all-roots table:
|
|
(hash-set! ht info-path 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 info-path
|
|
(and all-ok? (hash-copy t)))
|
|
t)))
|
|
;; process all collections:
|
|
(for ([cc ccs-to-compile])
|
|
(define domain
|
|
(with-handlers ([exn:fail? (lambda (x) (lambda () null))])
|
|
(parameterize ([current-namespace info-ns])
|
|
(dynamic-require (build-path (cc-path cc) "info.rkt")
|
|
'#%info-domain))))
|
|
;; Get the table for this cc's info-domain cache:
|
|
(define t (get-info-ht (cc-info-root cc)
|
|
(cc-info-path cc)
|
|
(cc-info-path-mode cc)))
|
|
(define-values (path->info-relative info-relative->path)
|
|
;; Look up value that was forced by by `get-info-ht':
|
|
(apply values (hash-ref roots (cc-info-root cc))))
|
|
;; Add this collection's info to the table, replacing any information
|
|
;; already there, if the collection has an "info.ss" file:
|
|
(when (or (file-exists? (build-path (cc-path cc) "info.rkt"))
|
|
(file-exists? (build-path (cc-path cc) "info.ss")))
|
|
(hash-set! t
|
|
(case (cc-info-path-mode cc)
|
|
[(relative)
|
|
;; Use relative path:
|
|
(path->info-relative (apply build-path
|
|
(cc-info-root cc)
|
|
(cc-collection cc)))]
|
|
[(abs-in-relative)
|
|
;; Try relative to `lib':
|
|
(let ([p (path->main-lib-relative (cc-path cc))])
|
|
(if (path? p)
|
|
;; Fall back to relative (with ".."s) to info root:
|
|
(let ([rp (find-relative-path (cc-info-root cc)
|
|
p
|
|
#:more-than-root? #t)])
|
|
(if (relative-path? rp)
|
|
(encode-relative-path rp)
|
|
(path->bytes rp)))
|
|
p))]
|
|
[else (path->bytes (cc-path cc))])
|
|
(cons (domain) (cc-shadowing-policy cc)))))
|
|
;; In "tidy" mode, make sure we check each "cache.rktd":
|
|
(when (or (make-tidy)
|
|
no-specific-collections?)
|
|
(for ([c (in-list (current-library-collection-paths))])
|
|
(when (and (directory-exists? c)
|
|
(not (and (avoid-main-installation)
|
|
(hash-ref main-collects-dirs c #f))))
|
|
(define info-path (build-path c "info-domain" "compiled" "cache.rktd"))
|
|
(when (file-exists? info-path)
|
|
(get-info-ht c info-path 'relative))))
|
|
(unless (avoid-main-installation)
|
|
(define info-root (find-share-dir))
|
|
(define info-path (build-path info-root "info-cache.rktd"))
|
|
(when (file-exists? info-path)
|
|
(get-info-ht info-root info-path 'abs-in-relative)))
|
|
(when (make-user)
|
|
(define info-root (find-user-share-dir))
|
|
(define info-path (build-path info-root "info-cache.rktd"))
|
|
(when (file-exists? info-path)
|
|
(get-info-ht info-root info-path 'abs-in-relative))
|
|
(define planet-info-path (get-planet-cache-path))
|
|
(when (file-exists? planet-info-path)
|
|
(get-info-ht #f planet-info-path 'abs))))
|
|
;; 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))
|
|
(define-values [base name dir?] (split-path info-path))
|
|
(make-directory* base)
|
|
(define p info-path)
|
|
(setup-printf "updating" "~a" (path->relative-string/setup
|
|
p
|
|
#:cache pkg-path-cache))
|
|
(when (verbose)
|
|
(define ht0 (hash-ref ht-orig info-path))
|
|
(when ht0
|
|
(for ([(k v) (in-hash ht)])
|
|
(define v2 (hash-ref ht0 k #f))
|
|
(unless (equal? v v2)
|
|
(printf " ~s -> ~s\n instead of ~s\n" k v v2)))
|
|
(for ([(k v) (in-hash ht0)])
|
|
(unless (hash-ref ht k #f)
|
|
(printf " ~s removed\n" k)))))
|
|
(with-handlers ([exn:fail? (warning-handler (void))])
|
|
(with-output-to-file p #:exists 'truncate/replace
|
|
(lambda ()
|
|
(write (hash-map ht cons))
|
|
(newline)))))))
|
|
;; Flush cached state in the current namespace:
|
|
(reset-relevant-directories-state!))
|
|
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; 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
|
|
(parallel-workers)
|
|
(parallel-use-places)
|
|
name-str
|
|
(if no-specific-collections? #f (map cc-path ccs-to-compile))
|
|
latex-dest auto-start-doc? (make-user) (force-user-docs)
|
|
(make-tidy) (avoid-main-installation)
|
|
(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)
|
|
(set! exit-code 1)
|
|
(setup-printf #f "docs failure: ~a" (exn->string exn)))])
|
|
(define auto-start-doc?
|
|
(or (and (not (null? (archives)))
|
|
(archive-implies-reindex))
|
|
(make-doc-index)))
|
|
(doc:setup-scribblings #f auto-start-doc?)))
|
|
|
|
(define (doc-pdf-dest-step)
|
|
(setup-printf #f "--- building PDF documentation (via pdflatex) ---")
|
|
(define dest-dir (path->complete-path (doc-pdf-dest)))
|
|
(unless (directory-exists? dest-dir)
|
|
(make-directory dest-dir))
|
|
(define 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 (path-has-extension? f #".tex"))
|
|
(define pdf (scr:call 'run-pdflatex f
|
|
(lambda (fmt . xs)
|
|
(apply setup-printf #f fmt xs))))
|
|
(define 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 ---")
|
|
(define (name-list l)
|
|
(unless (list-of relative-path-string? l)
|
|
(error "result is not a list of relative path strings:" l)))
|
|
(define (flags-list l)
|
|
(unless (list-of (list-of string?) l)
|
|
(error "result is not a list of strings:" l)))
|
|
(define ((or-f f) x) (when x (f x)))
|
|
(define created-launchers (make-hash))
|
|
(for ([cc ccs-to-make-launchers])
|
|
(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)))])
|
|
(define p (program-launcher-path mzln #:user? (not (cc-main? cc))))
|
|
(define addon-p (and (if (eq? kind 'gui)
|
|
(find-addon-tethered-gui-bin-dir)
|
|
(find-addon-tethered-console-bin-dir))
|
|
(program-launcher-path mzln #:user? #t #:tethered? #t)))
|
|
(define config-p (and (cc-main? cc)
|
|
(if (eq? kind 'gui)
|
|
(find-config-tethered-gui-bin-dir)
|
|
(find-config-tethered-console-bin-dir))
|
|
(program-launcher-path mzln #:user? #f #:tethered? #t)))
|
|
(define receipt-path
|
|
(build-path (if (cc-main? cc)
|
|
(find-lib-dir)
|
|
(find-user-lib-dir))
|
|
"launchers.rktd"))
|
|
(define (prep-dir p)
|
|
(define dir (path-only p))
|
|
(make-directory* dir))
|
|
(define skip-non-addon? (and (cc-main? cc)
|
|
(avoid-main-installation)))
|
|
(unless skip-non-addon?
|
|
(prep-dir p)
|
|
(prep-dir receipt-path)
|
|
(when config-p
|
|
(prep-dir config-p)))
|
|
(when addon-p
|
|
(prep-dir addon-p))
|
|
(hash-set! created-launchers
|
|
(record-launcher receipt-path mzln kind (current-launcher-variant)
|
|
(cc-collection cc) (cc-path cc))
|
|
#t)
|
|
(define (create p user? tethered?)
|
|
(define aux
|
|
(append
|
|
`((exe-name . ,mzln)
|
|
(relative? . ,(and (cc-main? cc)
|
|
(not tethered?)
|
|
(not (get-absolute-installation?))))
|
|
(install-mode . ,(if tethered?
|
|
(if user? 'addon-tethered 'config-tethered)
|
|
(if (cc-main? cc) 'main 'user)))
|
|
,@(build-aux-from-path
|
|
(build-path (cc-path cc)
|
|
(path-replace-extension (or mzll mzln) #""))))))
|
|
(unless (up-to-date? p aux)
|
|
(setup-printf
|
|
"launcher"
|
|
"~a~a"
|
|
(case kind
|
|
[(gui) (path->relative-string/gui-bin p)]
|
|
[(console) (path->relative-string/console-bin p)]
|
|
[else (error 'make-launcher "internal error (~s)" kind)])
|
|
(let ([v (current-launcher-variant)])
|
|
(if (eq? v (cross-system-type 'gc)) "" (format " [~a]" v))))
|
|
(make-launcher
|
|
#:tether-mode (if tethered?
|
|
(if user?
|
|
'addon
|
|
'config)
|
|
#f)
|
|
(append
|
|
(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)))
|
|
(unless skip-non-addon?
|
|
(create p (not (cc-main? cc)) #f)
|
|
(when config-p
|
|
(create config-p #f #t)))
|
|
(when addon-p
|
|
(create addon-p #t #t)))]
|
|
[else
|
|
(define 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?)))))
|
|
(when (or no-specific-collections?
|
|
(make-tidy))
|
|
(unless (avoid-main-installation)
|
|
(tidy-launchers #f
|
|
(find-lib-dir)
|
|
created-launchers
|
|
ccs-to-compile))
|
|
(when (make-user)
|
|
(tidy-launchers #t
|
|
(find-user-lib-dir)
|
|
created-launchers
|
|
ccs-to-compile))))
|
|
|
|
(define (read-receipt-hash receipt-path)
|
|
(if (file-exists? receipt-path)
|
|
(with-handlers ([exn:fail?
|
|
(lambda (exn)
|
|
(setup-printf
|
|
"WARNING"
|
|
"error reading receipts ~s: ~a"
|
|
receipt-path
|
|
(exn-message exn))
|
|
#hash())])
|
|
(call-with-input-file*
|
|
receipt-path
|
|
(lambda (i)
|
|
(define ht (read i))
|
|
(if (hash? ht)
|
|
ht
|
|
(error "content is not a hash table")))))
|
|
#hash()))
|
|
|
|
(define (write-receipt-hash receipt-path ht)
|
|
(call-with-output-file*
|
|
#:exists 'truncate/replace
|
|
receipt-path
|
|
(lambda (o) (write ht o) (newline o))))
|
|
|
|
(define (record-launcher receipt-path name kind variant coll coll-path)
|
|
(let ([ht (read-receipt-hash receipt-path)])
|
|
(define exe-key (vector kind
|
|
variant
|
|
name))
|
|
(define exe-val (map path->string coll))
|
|
(unless (equal? (hash-ref ht exe-key #f)
|
|
exe-val)
|
|
(let ([ht (hash-set ht exe-key exe-val)])
|
|
(write-receipt-hash receipt-path ht)))
|
|
exe-key))
|
|
|
|
(define (tidy-launchers user? lib-dir created ccs-to-compile)
|
|
(define receipt-path (build-path lib-dir "launchers.rktd"))
|
|
(define ht (read-receipt-hash receipt-path))
|
|
(define ht2 (for/fold ([ht (hash)]) ([(k v) (in-hash ht)])
|
|
(define coll-path (and (pair? v)
|
|
(list? v)
|
|
(andmap path-string? v)
|
|
(apply collection-path v #:fail (lambda (s) #f))))
|
|
(cond
|
|
[(hash-ref created k #f)
|
|
;; just created it, so keep it
|
|
(hash-set ht k v)]
|
|
[(and coll-path
|
|
;; If we set up this collection, then the launcher
|
|
;; must be in the created list if it's to be kept:
|
|
(let ([coll (map string->path v)])
|
|
(not
|
|
(for/or ([cc (in-list ccs-to-compile)])
|
|
(equal? coll (cc-collection cc))))))
|
|
;; keep the launcher
|
|
(hash-set ht k v)]
|
|
[else
|
|
;; remove the launcher
|
|
(define kind (vector-ref k 0))
|
|
(define variant (vector-ref k 1))
|
|
(define name (vector-ref k 2))
|
|
(parameterize ([current-launcher-variant variant])
|
|
(define (get-path user? tethered?)
|
|
((if (eq? kind 'gui)
|
|
gracket-program-launcher-path
|
|
racket-program-launcher-path)
|
|
name
|
|
#:user? user?
|
|
#:tethered? tethered?))
|
|
(define exe-path (get-path user? #f))
|
|
(define config-exe-path (and (not user?) (get-path #f #t)))
|
|
(define addon-exe-path (get-path #t #t))
|
|
(define is-dir?
|
|
(if (eq? kind 'gui)
|
|
(gracket-launcher-is-actually-directory?)
|
|
(racket-launcher-is-actually-directory?)))
|
|
(define (delete exe-path)
|
|
(define rel-exe-path
|
|
((if (eq? kind 'gui)
|
|
path->relative-string/gui-bin
|
|
path->relative-string/console-bin)
|
|
exe-path))
|
|
(cond
|
|
[(and (not is-dir?) (file-exists? exe-path))
|
|
(setup-printf "deleting" "launcher ~a" rel-exe-path)
|
|
(delete-file exe-path)]
|
|
[(and is-dir? (directory-exists? exe-path))
|
|
(setup-printf "deleting" "launcher ~a" rel-exe-path)
|
|
(delete-directory/files exe-path)]))
|
|
(delete exe-path)
|
|
(when config-exe-path (delete config-exe-path))
|
|
(when addon-exe-path (delete addon-exe-path))
|
|
;; Clean up any associated .desktop file and icon file:
|
|
(when (eq? 'unix (cross-system-type))
|
|
(let ([desktop (installed-executable-path->desktop-path
|
|
exe-path
|
|
user?)])
|
|
(when (file-exists? desktop)
|
|
(setup-printf "deleting" "desktop file ~a"
|
|
(path->relative-string/share desktop))
|
|
(delete-file desktop))
|
|
(for ([ext (in-list '(#"ico" #"png"))])
|
|
(define icon (installed-desktop-path->icon-path desktop
|
|
user?
|
|
ext))
|
|
(when (file-exists? icon)
|
|
(setup-printf "deleting" "icon file ~a"
|
|
(path->relative-string/share icon))
|
|
(delete-file icon))))))
|
|
ht])))
|
|
(unless (equal? ht ht2)
|
|
(setup-printf "updating" "launcher list")
|
|
(write-receipt-hash receipt-path ht2)))
|
|
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Foriegn Libraries and Man Pages ;;
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define (make-copy/move-step what
|
|
whats
|
|
what/title
|
|
copy-tag
|
|
move-tag
|
|
find-target-dir
|
|
find-user-target-dir
|
|
path->relative-string/*
|
|
receipt-file
|
|
receipt-at-dest?
|
|
check-entry
|
|
build-dest-path
|
|
this-platform?
|
|
fixup-lib
|
|
copy-user-lib)
|
|
(define (make-libs-step)
|
|
(setup-printf #f (format "--- installing ~a ---" whats))
|
|
(define installed-libs (make-hash))
|
|
(define dests (make-hash))
|
|
(for ([cc ccs-to-compile])
|
|
(begin-record-error cc what/title
|
|
(define info (cc-info cc))
|
|
(define copy-libs
|
|
(call-info info copy-tag (lambda () null) check-entry))
|
|
(define move-libs
|
|
(call-info info move-tag (lambda () null) check-entry))
|
|
|
|
(unless (or (and (null? copy-libs)
|
|
(null? move-libs))
|
|
(not (this-platform? info)))
|
|
(define dir (if (cc-main? cc)
|
|
(find-target-dir)
|
|
(find-user-target-dir)))
|
|
(define r-dir (if receipt-at-dest?
|
|
dir
|
|
(if (cc-main? cc)
|
|
(find-lib-dir)
|
|
(find-user-lib-dir))))
|
|
(define receipt-path (build-path r-dir receipt-file))
|
|
(make-directory* dir)
|
|
(make-directory* r-dir)
|
|
|
|
(define (copy-lib lib moving?)
|
|
(define src (path->complete-path lib (cc-path cc)))
|
|
(define lib-name (file-name-from-path lib))
|
|
(define dest (build-dest-path dir lib-name))
|
|
(define already? (or (and moving?
|
|
(not (file-exists? src))
|
|
(not (directory-exists? src))
|
|
(or (file-exists? dest)
|
|
(directory-exists? dest)))
|
|
(same-content? src dest)))
|
|
(unless already?
|
|
(setup-printf "installing" (string-append what " ~a")
|
|
(path->relative-string/* dest)))
|
|
(hash-set!
|
|
installed-libs
|
|
(record-lib receipt-path lib-name (cc-collection cc) (cc-path cc))
|
|
#t)
|
|
(unless already?
|
|
(hash-set! dests dest #t)
|
|
(delete-directory/files/hard dest)
|
|
(make-parent-directory* dest)
|
|
(if (file-exists? src)
|
|
(if (cc-main? cc)
|
|
(copy-file src dest)
|
|
(copy-user-lib src dest))
|
|
(copy-directory/files src dest)))
|
|
src)
|
|
|
|
(for ([lib (in-list copy-libs)])
|
|
(copy-lib lib #f))
|
|
|
|
(for ([lib (in-list move-libs)])
|
|
(define src (copy-lib lib #t))
|
|
(delete-directory/files src #:must-exist? #f)))))
|
|
(when (or no-specific-collections?
|
|
(make-tidy))
|
|
(unless (avoid-main-installation)
|
|
(tidy-libs #f
|
|
(find-target-dir)
|
|
(if receipt-at-dest?
|
|
(find-target-dir)
|
|
(find-lib-dir))
|
|
installed-libs
|
|
ccs-to-compile))
|
|
(when (make-user)
|
|
(tidy-libs #t
|
|
(find-user-target-dir)
|
|
(if receipt-at-dest?
|
|
(find-user-target-dir)
|
|
(find-user-lib-dir))
|
|
installed-libs
|
|
ccs-to-compile)))
|
|
(for-each fixup-lib (hash-keys dests)))
|
|
|
|
(define (same-content? a b)
|
|
(cond
|
|
[(file-exists? a)
|
|
(cond
|
|
[(file-exists? b)
|
|
(call-with-input-file*
|
|
a
|
|
(lambda (a)
|
|
(call-with-input-file*
|
|
b
|
|
(lambda (b)
|
|
(define as (make-bytes 4096))
|
|
(define bs (make-bytes 4096))
|
|
(let loop ()
|
|
(define an (read-bytes! as a))
|
|
(define bn (read-bytes! bs b))
|
|
(and (equal? an bn)
|
|
(equal? as bs)
|
|
(or (eof-object? an)
|
|
(loop))))))))]
|
|
[else #f])]
|
|
[(directory-exists? a)
|
|
(cond
|
|
[(directory-exists? b)
|
|
(define (path<? a b) (bytes<? (path->bytes a) (path->bytes b)))
|
|
(define al (sort (directory-list a) path<?))
|
|
(define bl (sort (directory-list b) path<?))
|
|
(and (equal? al bl)
|
|
(andmap same-content?
|
|
(map (lambda (f) (build-path a f)) al)
|
|
(map (lambda (f) (build-path b f)) bl)))]
|
|
[else #f])]
|
|
[else #f]))
|
|
|
|
(define (record-lib receipt-path name coll coll-path)
|
|
(let ([ht (read-receipt-hash receipt-path)])
|
|
(define lib-key (path-element->bytes name))
|
|
(define lib-val (map path->string coll))
|
|
(unless (equal? (hash-ref ht lib-key #f)
|
|
lib-val)
|
|
(let ([ht (hash-set ht lib-key lib-val)])
|
|
(write-receipt-hash receipt-path ht)))
|
|
lib-key))
|
|
|
|
(define (tidy-libs user? target-dir receipt-dir installed-libs ccs-to-compile)
|
|
(clean-previous-delete-failures receipt-dir path->relative-string/*)
|
|
(define receipt-path (build-path receipt-dir receipt-file))
|
|
(define ht (read-receipt-hash receipt-path))
|
|
(define ht2 (for/fold ([ht (hash)]) ([(k v) (in-hash ht)])
|
|
(define coll-path (and (pair? v)
|
|
(list? v)
|
|
(andmap path-string? v)
|
|
(apply collection-path v #:fail (lambda (s) #f))))
|
|
(cond
|
|
[(hash-ref installed-libs k #f)
|
|
;; just installed it, so keep it
|
|
(hash-set ht k v)]
|
|
[(and coll-path
|
|
;; If we set up this collection, then the lib
|
|
;; must be in the installed list if it's to be kept:
|
|
(let ([coll (map string->path v)])
|
|
(not
|
|
(for/or ([cc (in-list ccs-to-compile)])
|
|
(equal? coll (cc-collection cc))))))
|
|
;; keep the lib
|
|
(hash-set ht k v)]
|
|
[else
|
|
;; remove the lib
|
|
(define lib-path (build-dest-path target-dir (bytes->path-element k)))
|
|
(when (or (file-exists? lib-path)
|
|
(directory-exists? lib-path))
|
|
(setup-printf "deleting" (string-append what " ~a")
|
|
(path->relative-string/* lib-path))
|
|
(delete-directory/files/hard lib-path))
|
|
ht])))
|
|
(unless (equal? ht ht2)
|
|
(setup-printf "updating" (format "~a list" what))
|
|
(write-receipt-hash receipt-path ht2)))
|
|
|
|
make-libs-step)
|
|
|
|
(define make-foreign-libs-step
|
|
(make-copy/move-step "foreign library"
|
|
"foreign libraries"
|
|
"foreign library setup"
|
|
'copy-foreign-libs
|
|
'move-foreign-libs
|
|
find-lib-dir
|
|
find-user-lib-dir
|
|
path->relative-string/lib
|
|
"libs.rktd" #t
|
|
(lambda (l)
|
|
(unless (list-of relative-path-string? l)
|
|
(error "entry is not a list of relative path strings:" l)))
|
|
build-path
|
|
this-platform?
|
|
(case (cross-system-type)
|
|
[(macosx)
|
|
adjust-dylib-path/install]
|
|
[else void])
|
|
(case (cross-system-type)
|
|
[(unix)
|
|
copy-file/install-elf-rpath]
|
|
[else copy-file])))
|
|
|
|
(define make-shares-step
|
|
(make-copy/move-step "shared file"
|
|
"shared files"
|
|
"share files setup"
|
|
'copy-shared-files
|
|
'move-shared-files
|
|
find-share-dir
|
|
find-user-share-dir
|
|
path->relative-string/share
|
|
"shares.rktd" #t
|
|
(lambda (l)
|
|
(unless (list-of relative-path-string? l)
|
|
(error "entry is not a list of relative path strings:" l)))
|
|
build-path
|
|
this-platform?
|
|
void
|
|
copy-file))
|
|
|
|
(define make-mans-step
|
|
(make-copy/move-step "man page"
|
|
"man pages"
|
|
"man page setup"
|
|
'copy-man-pages
|
|
'move-man-pages
|
|
find-man-dir
|
|
find-user-man-dir
|
|
path->relative-string/man
|
|
"mans.rktd" #f
|
|
(lambda (l)
|
|
(unless (list-of (lambda (p)
|
|
(and (relative-path-string? p)
|
|
(filename-extension p)))
|
|
l)
|
|
(error
|
|
"entry is not a list of relative path strings,each with a non-empty extension:"
|
|
l)))
|
|
(lambda (d n)
|
|
(build-path d
|
|
(bytes->path-element (bytes-append #"man" (filename-extension n)))
|
|
n))
|
|
(lambda (info) #t)
|
|
void
|
|
copy-file))
|
|
|
|
(define setup-delete-prefix #"raco-setup-delete-")
|
|
|
|
(define (delete-directory/files/hard dest)
|
|
(cond
|
|
[(and (eq? 'windows (system-type))
|
|
(file-exists? dest))
|
|
;; To handle DLLs that may be opened, try moving and then
|
|
;; deleting. The delete may well fail, but at least the
|
|
;; file will be out of the way for another try.
|
|
(define-values (base name dir?) (split-path dest))
|
|
(define delete-dest (build-path base
|
|
(bytes->path-element
|
|
(bytes-append
|
|
setup-delete-prefix
|
|
(path-element->bytes name)))))
|
|
(rename-file-or-directory dest delete-dest #t)
|
|
(try-delete-file delete-dest)]
|
|
[else
|
|
(delete-directory/files dest #:must-exist? #f)]))
|
|
|
|
(define (try-delete-file f)
|
|
(with-handlers ([exn:fail:filesystem?
|
|
(lambda (exn)
|
|
(setup-printf
|
|
"WARNING"
|
|
"error deleteing file: ~a"
|
|
(exn-message exn)))])
|
|
(delete-file f)))
|
|
|
|
(define (clean-previous-delete-failures lib-dir path->relative-string/*)
|
|
(when (and (eq? 'windows (system-type))
|
|
(directory-exists? lib-dir))
|
|
(for ([f (in-list (directory-list lib-dir))])
|
|
(define bstr (path-element->bytes f))
|
|
(when (equal? (subbytes bstr 0 (min (bytes-length setup-delete-prefix)
|
|
(bytes-length bstr)))
|
|
setup-delete-prefix)
|
|
(define p (build-path lib-dir f))
|
|
(setup-printf "deleting" (path->relative-string/* p))
|
|
(try-delete-file (build-path lib-dir f))))))
|
|
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Package-dependency checking ;;
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define (do-check-package-dependencies)
|
|
(setup-printf #f (format "--- checking package dependencies ---"))
|
|
(unless (check-package-dependencies (map cc-path ccs-to-compile)
|
|
(map cc-collection ccs-to-compile)
|
|
(map cc-main? ccs-to-compile)
|
|
;; If "test" or "scribblings" is this collection's name,
|
|
;; then it's build-mode code, otherwise it's test mode:
|
|
(let ([tests-path (string->path "tests")]
|
|
[scribblings-path (string->path "scribblings")])
|
|
(for/list ([cc (in-list ccs-to-compile)])
|
|
(and (cc-collection cc) ; #f for a PLaneT package
|
|
(if (or (member tests-path (cc-collection cc))
|
|
(member scribblings-path (cc-collection cc)))
|
|
'build
|
|
'run))))
|
|
setup-printf setup-fprintf
|
|
(check-unused-dependencies)
|
|
(fix-dependencies)
|
|
(verbose)
|
|
(not no-specific-collections?)
|
|
(always-check-dependencies))
|
|
(set! exit-code 1)))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; setup Body ;;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(setup-printf "version" "~a" (version))
|
|
(setup-printf "platform" "~a [~a]" (cross-system-library-subpath #f) (cross-system-type 'gc))
|
|
(setup-printf "installation name" "~a" (get-installation-name))
|
|
(setup-printf "variants" "~a" (string-join (map symbol->string (available-mzscheme-variants)) ", "))
|
|
(setup-printf "main collects" "~a" main-collects-dir)
|
|
(setup-printf "collects paths" (if (null? (current-library-collection-paths)) " empty!" ""))
|
|
(for ([p (current-library-collection-paths)])
|
|
(setup-printf #f " ~a" p))
|
|
(setup-printf "main pkgs" "~a" (find-pkgs-dir))
|
|
(setup-printf "pkgs paths" "")
|
|
(for ([p (get-pkgs-search-dirs)])
|
|
(setup-printf #f " ~a" p))
|
|
(setup-printf #f " ~a" (find-user-pkgs-dir))
|
|
(setup-printf "links files" "")
|
|
(for ([p (get-links-search-files)])
|
|
(setup-printf #f " ~a" p))
|
|
(when (use-user-specific-search-paths)
|
|
(setup-printf #f " ~a" (find-user-links-file)))
|
|
(setup-printf "main docs" "~a" (find-doc-dir))
|
|
|
|
(when (and (not (null? (archives))) no-specific-collections?)
|
|
(done))
|
|
|
|
(when (make-info-domain) (make-info-domain-step))
|
|
|
|
(when (clean) (clean-step))
|
|
(when (make-zo)
|
|
(compiler:option:verbose (compiler-verbose))
|
|
(compiler:option:compile-subcollections #f))
|
|
|
|
(do-install-part 'pre)
|
|
|
|
(when (make-foreign-libs)
|
|
(make-foreign-libs-step)
|
|
(make-shares-step))
|
|
|
|
(when (make-zo) (make-zo-step))
|
|
|
|
(when (make-launchers) (make-launchers-step))
|
|
(when (make-launchers)
|
|
(unless (eq? 'windows (cross-system-type))
|
|
(make-mans-step)))
|
|
|
|
(when make-docs?
|
|
(make-docs-step))
|
|
(when (doc-pdf-dest) (doc-pdf-dest-step))
|
|
|
|
(do-install-part 'general)
|
|
(do-install-part 'post)
|
|
|
|
(when (and (check-dependencies)
|
|
(or no-specific-collections?
|
|
(always-check-dependencies)))
|
|
(do-check-package-dependencies))
|
|
|
|
(done))
|