suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Rackety (indentation, let->define, mzscheme->racket/base, module -> #lang)

Browse Source
This commit is contained in:
Robby Findler 2011-08-19 08:01:47 -05:00
parent 5455a16f47
commit 4d5a3fa971
1 changed files with 100 additions and 101 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

177
collects/setup/plt-single-installer.rkt
View File

@ -1,102 +1,101 @@
(module plt-single-installer mzscheme #lang racket/base
(require mzlib/unit (require racket/unit
mzlib/etc
;; All the rest are to get the imports for setup@: ;; All the rest are to get the imports for setup@:
"option-sig.rkt" "option-sig.rkt"
"setup-unit.rkt" "setup-unit.rkt"
"option-unit.rkt" "option-unit.rkt"
launcher/launcher-sig launcher/launcher-sig
launcher/launcher-unit launcher/launcher-unit
dynext/dynext-sig dynext/dynext-sig
dynext/dynext-unit dynext/dynext-unit
compiler/sig compiler/sig
compiler/option-unit compiler/option-unit
compiler/compiler-unit) compiler/compiler-unit)
(provide run-single-installer install-planet-package clean-planet-package reindex-user-documentation) (provide run-single-installer install-planet-package clean-planet-package reindex-user-documentation)
;; run-single-installer : string (-> string) -> void ;; run-single-installer : string (-> string) -> void
;; runs the instealler on the given package ;; runs the installer on the given package
(define (run-single-installer file get-target-dir) (define (run-single-installer file get-target-dir)
(run-single-installer/internal file get-target-dir #f #f #f)) (run-single-installer/internal file get-target-dir #f #f #f))
;; install-planet-package : path path (list string string (listof string) nat nat) -> void ;; install-planet-package : path path (list string string (listof string) nat nat) -> void
;; unpacks and installs the given planet package into the given path ;; unpacks and installs the given planet package into the given path
(define (install-planet-package file directory spec) (define (install-planet-package file directory spec)
(run-single-installer/internal file (lambda () directory) (cons directory spec) #f #f)) (run-single-installer/internal file (lambda () directory) (cons directory spec) #f #f))
;; clean-planet-package : path (list string string (listof string) nat nat) -> void ;; clean-planet-package : path (list string string (listof string) nat nat) -> void
;; cleans the given planet package ;; cleans the given planet package
(define (clean-planet-package directory spec) (define (clean-planet-package directory spec)
(run-single-installer/internal #f (lambda () directory) (cons directory spec) #f #t)) (run-single-installer/internal #f (lambda () directory) (cons directory spec) #f #t))
;; reindex-user-documentation ;; reindex-user-documentation
;; call after installing or uninstalling a set of Planet packages ;; call after installing or uninstalling a set of Planet packages
(define (reindex-user-documentation) (define (reindex-user-documentation)
(run-single-installer/internal #f current-directory #f '(("scribblings/main/user")) #f)) (run-single-installer/internal #f current-directory #f '(("scribblings/main/user")) #f))
;; run-single-installer : string (-> string) (list path string string nat nat) -> void ;; run-single-installer : string (-> string) (list path string string nat nat) -> void
;; creates a separate thread, runs the installer in that thread, ;; creates a separate thread, runs the installer in that thread,
;; returns when the thread completes ;; returns when the thread completes
(define (run-single-installer/internal file get-target-dir planet-spec collections clean?) (define (run-single-installer/internal file get-target-dir planet-spec collections clean?)
(let ([cust (make-custodian)]) (define cust (make-custodian))
(parameterize ([current-custodian cust] (parameterize ([current-custodian cust]
[current-namespace (make-namespace)] [current-namespace (make-base-namespace)]
[exit-handler (lambda (v) (custodian-shutdown-all cust))]) [exit-handler (lambda (v) (custodian-shutdown-all cust))])
(let ([thd (define thd
(thread (thread
(lambda () (lambda ()
(define-unit set-options@ (define-unit set-options@
(import setup-option^ compiler^) (import setup-option^ compiler^)
(export) (export)
;; >>>>>>>>>>>>>> <<<<<<<<<<<<<<< ;; >>>>>>>>>>>>>> <<<<<<<<<<<<<<<
;; Here's where we tell setup the archive file! ;; Here's where we tell setup the archive file:
(unless (or clean? (not file)) (unless (or clean? (not file))
(archives (list file)) (archives (list file))
(when planet-spec (when planet-spec
(archive-implies-reindex #f))) (archive-implies-reindex #f)))
;; Here's where we make get a directory: ;; Here's where we make get a directory:
(current-target-directory-getter (current-target-directory-getter
get-target-dir) get-target-dir)
(when planet-spec (when planet-spec
(specific-planet-dirs (list planet-spec))) (specific-planet-dirs (list planet-spec)))
(when collections (when collections
(specific-collections collections)) (specific-collections collections))
(when clean? (when clean?
(clean #t) (clean #t)
(make-zo #f) (make-zo #f)
(make-launchers #f) (make-launchers #f)
(make-info-domain #t) (make-info-domain #t)
(call-install #f) (call-install #f)
(make-docs #f)) (make-docs #f))
(setup-program-name "raco setup") (setup-program-name "raco setup")
(parallel-workers 1)) (parallel-workers 1))
(invoke-unit (invoke-unit
(compound-unit/infer (compound-unit/infer
(import) (import)
(export) (export)
(link launcher@ (link launcher@
dynext:compile@ dynext:compile@
dynext:link@ dynext:link@
dynext:file@ dynext:file@
compiler:option@ compiler:option@
compiler@ compiler@
setup:option@ setup:option@
set-options@ set-options@
setup@)))))]) setup@))))))
(dynamic-wind (dynamic-wind
void void
(lambda () (lambda ()
(with-handlers ([exn:break? (lambda (exn) (with-handlers ([exn:break? (lambda (exn)
(break-thread thd) (break-thread thd)
(sleep 0.1) (sleep 0.1)
(raise exn))]) (raise exn))])
(thread-wait thd))) (thread-wait thd)))
(lambda () (custodian-shutdown-all cust)))))))) (lambda () (custodian-shutdown-all cust)))))