Split pkg-build from the main repository.
The `drdr2` pkg is now at https://github.com/racket/pkg-build
This commit is contained in:
Sam Tobin-Hochstadt
parent
4ace325562
commit
8fa26e6f4f
|
|
@ -1,191 +0,0 @@
|
|||
#lang at-exp racket/base
|
||||
(require scribble/html
|
||||
plt-web
|
||||
(only-in plt-web/style columns))
|
||||
|
||||
(provide make-about)
|
||||
|
||||
(define (here . c)
|
||||
(columns 10 #:row? #t (body c)))
|
||||
|
||||
(define (hx . c)
|
||||
@h5{@b[c]})
|
||||
|
||||
(define (make-about page-site)
|
||||
(define page-title "About Package Builds")
|
||||
(define (literal-url s)
|
||||
@a[href: s s])
|
||||
(page #:site page-site
|
||||
#:file "about.html"
|
||||
#:title page-title
|
||||
(html (head (title page-title))
|
||||
|
||||
@here{@h3[page-title]
|
||||
|
||||
@p{For every package that is registered at
|
||||
@literal-url{http://pkgs.racket-lang.org/}, the package-build service
|
||||
starts with the current release, periodically checks for package
|
||||
updates, and attempts to build each package that has changed or has a
|
||||
dependency that has changed.}
|
||||
|
||||
@p{When a package installation succeeds,
|
||||
tests in the package are run with}
|
||||
|
||||
@pre{ raco test --drdr}
|
||||
|
||||
@p{}
|
||||
|
||||
@p{Packages are built on a 64-bit Linux virtual
|
||||
machine (VM) that is isolated from the network. Each package build
|
||||
starts with a fresh instance of the virtual machine, and
|
||||
packages are re-packaged in built form for use by other
|
||||
packages. Testing of a package starts with a fresh instance of the
|
||||
virtual machine and a fresh installation of the package from its built
|
||||
form.}
|
||||
|
||||
@; ----------------------------------------
|
||||
@h3{Limitations}
|
||||
|
||||
@hx{Only Packages from the Main Catalog are Supported}
|
||||
|
||||
@p{The package-build service does not support
|
||||
references to @a[href: "http://planet.racket-lang.org"]{PLaneT
|
||||
packages} or to compatibility packages at
|
||||
@literal-url{http://planet-compats.racket-lang.org/}. When a package
|
||||
depends on one of those, then the package installation fails, because
|
||||
package builds are performed on a VM without network
|
||||
connectivity.}
|
||||
|
||||
@hx{Few System Libraries are Installed}
|
||||
|
||||
@p{Each package is installed on a minimal VM that
|
||||
omits as many system libraries and tools as is practical. If building
|
||||
on the minimal VM fails, the package build is retried on a VM with
|
||||
more tools and libraries, including a C compiler and an X server
|
||||
running at @tt{:1}. Look for @|ldquo|extra system dependencies@|rdquo| in
|
||||
the result column for packages that don@|rsquo|t work in the minimal
|
||||
environment but do work in the extended one.}
|
||||
|
||||
@p{The idea behind the minimal VM is that a
|
||||
package generally shouldn@|rsquo|t rely on tools that a Racket user
|
||||
may not have installed@|mdash|and so it@|rsquo|s worth reporting
|
||||
those problems from the package-build service. At the same time, a
|
||||
package might be intended to work only in a typical Unix setup, and
|
||||
witholding a C compiler, for example, would be especially uncooperative of
|
||||
the package-build service.}
|
||||
|
||||
@hx{Test Capabilities May Be Limited}
|
||||
|
||||
@p{Limited system libraries, missing network
|
||||
connectivity, or other constraints may prevent the package-build
|
||||
service from straighforwardly running a package@|rsquo|s tests. See
|
||||
@a[href: "#test"]{Dealing with Test Failures}.}
|
||||
|
||||
@hx{Native Libraries Need Special Handling}
|
||||
|
||||
@p{Even on the extended VM, the available system
|
||||
libraries are limited. See @a[href: "#foreign"]{Working with Native
|
||||
Libraries} below for information on implementing packages that rely on
|
||||
additional native libraries.}
|
||||
|
||||
@; ----------------------------------------
|
||||
@h3[name: "test"]{Dealing Test Failures}
|
||||
|
||||
@p{In the absence of any @tt{"info.rkt"}-based
|
||||
specifications or @tt{test} submodules, @tt{raco test} runs each
|
||||
module in a package. Running a particular module might fail if
|
||||
it@|rsquo|s a program-starting module that expects command-line
|
||||
arguments, or a module might start a program that expects input and
|
||||
causes the test to time out.}
|
||||
|
||||
@p{In the simplest case, you can add a `test` submodule as}
|
||||
|
||||
@pre{ (module test racket/base)}
|
||||
|
||||
@p{}
|
||||
|
||||
@p{to make @tt{raco test} ignore the enclosing
|
||||
module. You can control @tt{raco test} in various other ways through
|
||||
submodules and @tt{"info.rkt"} files@";" see
|
||||
@a[href: "http://docs.racket-lang.org/raco/test.html"]{the
|
||||
documentation}.}
|
||||
|
||||
@p{The default timeout on an individual test is 90 seconds, and the
|
||||
overall timeout for testing a package is 10 minutes. You can adjust the
|
||||
former, but the latter is a hard limit for now.}
|
||||
|
||||
@p{Tests are always run on the extended VM, but even so,
|
||||
sometimes the package-build service cannot run a package@|rsquo|s tests. For
|
||||
example, if a package needs network access for testing, the
|
||||
package-build service can@|rsquo|t help, because it runs on an isolated
|
||||
VM. There@|rsquo|s no way for a package to opt out of
|
||||
testing, but a package author can implement a test suite that skip tests
|
||||
under adverse conditions. In case there@|rsquo|s no other way for a test
|
||||
suite to determine that it can@|rsquo|t run, the package-build service sets
|
||||
the @tt{PLT_PKG_BUILD_SERVICE} environment variable when running
|
||||
tests@";" a test suite can explicitly check for the environment
|
||||
variable and skip tests that can@|rsquo|t work.}
|
||||
|
||||
|
||||
@; ----------------------------------------
|
||||
@h3[name: "foreign"]{Working with Native Libraries}
|
||||
|
||||
@p{The @|ldquo|minimal@|rdquo| versus
|
||||
@|ldquo|extended@|rdquo| VM distinction begs the question of how the
|
||||
package-build service can support a package that relies on a native
|
||||
library@|mdash|one that is not installed even on the extended VM.}
|
||||
|
||||
@p{It would be nice to have a bridge between the
|
||||
Racket package system and the OS package manager so that dependencies
|
||||
on OS packages could be declared and installed. One catch is that the
|
||||
bridge would have to work with a package-build VM that is isolated
|
||||
from the network. The networking, permission, and maintenance issues
|
||||
seem complex enough that we haven@|rsquo|t embarked on that direction.}
|
||||
|
||||
@p{For now, the package-build installation
|
||||
identifies itself as running on the @tt{"x86_64-linux-natipkg"}
|
||||
platform, as opposed to plain @tt{"x86_64-linux"}. On the plain
|
||||
@tt{"x86_64-linux"} platform, native libraries as needed by Racket
|
||||
packages are expected to be installed by a user through the
|
||||
OS@|rsquo|s package manager. On the @tt{"x86_64-linux-natipkg"}
|
||||
platform, however, native libraries are handled as on Windows and Mac
|
||||
OS X: they are expected to be provided by platform-specific packages.}
|
||||
|
||||
@p{For example, on the @tt{"x86_64-linux-natipkg"}
|
||||
platform, the @tt{"math-lib"} package depends on the
|
||||
@tt{"math-x86_64-linux-natipkg"} package, which provides 64-bit Linux
|
||||
builds of GMP and MPFR. You can see that dependency declaration in the
|
||||
@tt{"info.rkt"} file for the @tt{"math-lib"} package:}
|
||||
|
||||
@pre{ @literal-url{https://github.com/plt/racket/blob/master/pkgs/math-pkgs/math-lib/info.rkt}}
|
||||
|
||||
@p{}
|
||||
|
||||
@p{If your package depends on a native
|
||||
library, then you currently have two main options:}
|
||||
|
||||
@hx{Accomodate Unavailable Libraries}
|
||||
|
||||
@p{One option is to make the package behave when the native library is unavailable.}
|
||||
|
||||
@p{Typically, a native library that is accessed via @tt{ffi/unsafe}
|
||||
isn@|rsquo|t needed to merely build a package
|
||||
(including its documentation). If possible, delay any use of the
|
||||
native library to run time so that the package can build without it.}
|
||||
|
||||
@p{For tests, you can either just let them fail, or you can adjust the
|
||||
test suite to avoid failure reports when the native library is
|
||||
unavailable or (if you must) when @tt{PLT_PKG_BUILD_SERVICE} is defined.}
|
||||
|
||||
@hx{Distribute Native Libraries}
|
||||
|
||||
@p{Another option is to build a 64-bit Linux
|
||||
version of the library, distribute it as a package, and make
|
||||
the package a platform-specific dependency of your package for the
|
||||
@tt{"x86_64-linux-natipkg"} platform.}
|
||||
|
||||
@p{This option is in many ways the best one for
|
||||
users and for testing@|mdash|especially if Windows and Mac OS X
|
||||
native-library packages are also provided@|mdash|but it@|rsquo|s more work.}
|
||||
|
||||
})))
|
||||
|
|
@ -1,51 +0,0 @@
|
|||
#lang racket/base
|
||||
(require net/url
|
||||
net/head
|
||||
racket/format
|
||||
racket/file
|
||||
racket/port)
|
||||
|
||||
(provide download-installer)
|
||||
|
||||
(define (download-installer snapshot-url installer-dir installer-name substatus)
|
||||
(define status-file (build-path installer-dir "status.rktd"))
|
||||
(define name+etag (and (file-exists? status-file)
|
||||
(call-with-input-file*
|
||||
status-file
|
||||
read)))
|
||||
(define installer-url (combine-url/relative (string->url snapshot-url)
|
||||
(~a "installers/" installer-name)))
|
||||
(define etag
|
||||
(cond
|
||||
[(equal? (url-scheme installer-url) "file")
|
||||
#f]
|
||||
[else
|
||||
(define p (head-impure-port installer-url))
|
||||
(define h (purify-port p))
|
||||
(close-input-port p)
|
||||
(extract-field "ETag" h)]))
|
||||
(cond
|
||||
[(and (file-exists? (build-path installer-dir installer-name))
|
||||
name+etag
|
||||
(equal? (car name+etag) installer-name)
|
||||
(cadr name+etag)
|
||||
(equal? (cadr name+etag) etag))
|
||||
(substatus "Using cached installer, Etag ~a\n" etag)]
|
||||
[else
|
||||
(delete-directory/files installer-dir #:must-exist? #f)
|
||||
(make-directory* installer-dir)
|
||||
(call/input-url
|
||||
installer-url
|
||||
get-pure-port
|
||||
(lambda (i)
|
||||
(call-with-output-file*
|
||||
(build-path installer-dir installer-name)
|
||||
#:exists 'replace
|
||||
(lambda (o)
|
||||
(copy-port i o)))))
|
||||
(when etag
|
||||
(call-with-output-file*
|
||||
status-file
|
||||
(lambda (o)
|
||||
(write (list installer-name etag) o)
|
||||
(newline o))))]))
|
||||
|
|
@ -1,40 +0,0 @@
|
|||
#lang racket/base
|
||||
(require racket/file
|
||||
racket/format
|
||||
setup/getinfo
|
||||
setup/collection-name
|
||||
file/unzip
|
||||
pkg/strip)
|
||||
|
||||
(provide extract-documentation)
|
||||
|
||||
(define (extract-documentation zip pkg dest-dir)
|
||||
(define temp-dir (make-temporary-file "docs~a" 'directory))
|
||||
(parameterize ([current-directory temp-dir])
|
||||
(unzip zip))
|
||||
(for ([d (in-directory temp-dir)])
|
||||
(cond
|
||||
[(directory-exists? d)
|
||||
(define i (get-info/full d
|
||||
#:namespace (make-base-namespace)
|
||||
#:bootstrap? #t))
|
||||
(when i
|
||||
(define l (i 'scribblings (lambda () null)))
|
||||
(when (list? l)
|
||||
(for ([s (in-list l)])
|
||||
(when (and (list? s)
|
||||
(pair? s)
|
||||
(path-string? (car s))
|
||||
(or ((length s) . < . 4)
|
||||
(collection-name-element? (list-ref s 3))))
|
||||
(define n (if ((length s) . < . 4)
|
||||
(let-values ([(base name dir?) (split-path (car s))])
|
||||
(path->string (path-replace-suffix name #"")))
|
||||
(list-ref s 3)))
|
||||
(when (directory-exists? (build-path d "doc" n))
|
||||
(define doc-dest (build-path dest-dir (~a n "@" pkg)))
|
||||
(copy-directory/files (build-path d "doc" n)
|
||||
doc-dest)
|
||||
(for ([p (in-directory doc-dest)])
|
||||
(when (regexp-match? #rx#"[.]html$" (path->bytes p))
|
||||
(fixup-local-redirect-reference p "../local-redirect"))))))))])))
|
||||
File diff suppressed because it is too large
Load Diff
|
|
@ -1,33 +0,0 @@
|
|||
#lang racket/base
|
||||
(require racket/cmdline
|
||||
pkg/lib)
|
||||
|
||||
;; This module is copied to the virtual machine to extract
|
||||
;; a package -> documentation mapping.
|
||||
|
||||
(define all-pkgs? #f)
|
||||
|
||||
(define want-pkgs
|
||||
(command-line
|
||||
#:once-each
|
||||
[("--all") "All packages"
|
||||
(set! all-pkgs? #t)]
|
||||
#:args
|
||||
want-pkg
|
||||
want-pkg))
|
||||
|
||||
(define ns (make-base-namespace))
|
||||
|
||||
(define ht
|
||||
(for/hash ([pkg (in-list
|
||||
(if all-pkgs?
|
||||
(installed-pkg-names #:scope 'installation)
|
||||
want-pkgs))])
|
||||
(define dir (pkg-directory pkg))
|
||||
(values pkg
|
||||
(if dir
|
||||
(pkg-directory->additional-installs dir pkg #:namespace ns)
|
||||
null))))
|
||||
|
||||
(write ht)
|
||||
(newline)
|
||||
|
|
@ -1,12 +0,0 @@
|
|||
#lang racket/base
|
||||
(require racket/cmdline
|
||||
pkg/lib)
|
||||
|
||||
(define scope 'installation)
|
||||
|
||||
(command-line
|
||||
#:once-each
|
||||
[("--user") "User scope" (set! scope 'user)])
|
||||
|
||||
(write (installed-pkg-names #:scope scope))
|
||||
|
||||
|
|
@ -1,35 +0,0 @@
|
|||
#lang racket/base
|
||||
(require racket/list)
|
||||
|
||||
(provide status
|
||||
substatus
|
||||
show-list)
|
||||
|
||||
(define (substatus fmt . args)
|
||||
(apply printf fmt args)
|
||||
(flush-output))
|
||||
|
||||
(define (status fmt . args)
|
||||
(printf ">> ")
|
||||
(apply substatus fmt args))
|
||||
|
||||
(define (show-list nested-strs #:indent [indent ""])
|
||||
(define strs (let loop ([strs nested-strs])
|
||||
(cond
|
||||
[(null? strs) null]
|
||||
[(pair? (car strs))
|
||||
(define l (car strs))
|
||||
(define len (length l))
|
||||
(loop (append
|
||||
(list (string-append "(" (car l)))
|
||||
(take (cdr l) (- len 2))
|
||||
(list (string-append (last l) ")"))
|
||||
(cdr strs)))]
|
||||
[else (cons (car strs) (loop (cdr strs)))])))
|
||||
(substatus "~a\n"
|
||||
(for/fold ([a indent]) ([s (in-list strs)])
|
||||
(if ((+ (string-length a) 1 (string-length s)) . > . 72)
|
||||
(begin
|
||||
(substatus "~a\n" a)
|
||||
(string-append indent " " s))
|
||||
(string-append a " " s)))))
|
||||
|
|
@ -1,182 +0,0 @@
|
|||
#lang at-exp racket/base
|
||||
(require racket/format
|
||||
racket/file
|
||||
scribble/html
|
||||
(only-in plt-web site page call-with-registered-roots)
|
||||
"about.rkt")
|
||||
|
||||
(provide summary-page
|
||||
(struct-out doc/main)
|
||||
(struct-out doc/extract)
|
||||
(struct-out doc/salvage)
|
||||
(struct-out doc/none)
|
||||
(struct-out conflicts/indirect))
|
||||
|
||||
(struct doc/main (name path) #:prefab)
|
||||
(struct doc/extract (name path) #:prefab)
|
||||
(struct doc/salvage (name path) #:prefab)
|
||||
(struct doc/none (name) #:prefab)
|
||||
|
||||
(struct conflicts/indirect (path) #:prefab)
|
||||
|
||||
(define (summary-page summary-ht dest-dir)
|
||||
(define page-site (site "pkg-build"
|
||||
#:url "http://pkg-build.racket-lang.org/"
|
||||
#:share-from (site "www"
|
||||
#:url "http://racket-lang.org/"
|
||||
#:generate? #f)
|
||||
#:navigation (list
|
||||
(lambda () (force about-page)))))
|
||||
(define about-page (delay (make-about page-site)))
|
||||
|
||||
(define page-title "Package Build Results")
|
||||
|
||||
(define summary
|
||||
(for/list ([pkg (in-list (sort (hash-keys summary-ht) string<?))])
|
||||
(define ht (hash-ref summary-ht pkg))
|
||||
(define failed? (and (hash-ref ht 'failure-log) #t))
|
||||
(define succeeded? (and (hash-ref ht 'success-log) #t))
|
||||
(define status
|
||||
(cond
|
||||
[(and failed? (not succeeded?)) 'failure]
|
||||
[(and succeeded? (not failed?)) 'success]
|
||||
[(and succeeded? failed?) 'confusion]
|
||||
[else 'unknown]))
|
||||
(define (more-status key [success-key #f])
|
||||
(if (eq? status 'success)
|
||||
(if (hash-ref ht key)
|
||||
'failure
|
||||
(if (or (not success-key)
|
||||
(hash-ref ht success-key))
|
||||
'success
|
||||
'unknown))
|
||||
'unknown))
|
||||
(define dep-status (more-status 'dep-failure-log))
|
||||
(define test-status (more-status 'test-failure-log 'test-success-log))
|
||||
(define min-status (more-status 'min-failure-log))
|
||||
(define docs (hash-ref ht 'docs))
|
||||
(define author (hash-ref ht 'author))
|
||||
(define conflicts-log (hash-ref ht 'conflicts-log))
|
||||
(tr (td pkg
|
||||
(div class: "author" author))
|
||||
(td (if (null? docs)
|
||||
""
|
||||
(list
|
||||
"Docs: "
|
||||
(add-between
|
||||
(for/list ([doc (in-list docs)])
|
||||
(cond
|
||||
[(doc/main? doc)
|
||||
(a href: (doc/main-path doc)
|
||||
(doc/main-name doc))]
|
||||
[(doc/extract? doc)
|
||||
(a href: (doc/extract-path doc)
|
||||
(doc/extract-name doc))]
|
||||
[(doc/salvage? doc)
|
||||
(list (a href: (doc/salvage-path doc)
|
||||
(doc/salvage-name doc))
|
||||
(span class: "annotation"
|
||||
nbsp
|
||||
"(salvaged)"))]
|
||||
[(doc/none? doc)
|
||||
(doc/none-name doc)]
|
||||
[else "???"]))
|
||||
", "))))
|
||||
(td class: (case status
|
||||
[(failure confusion) "stop"]
|
||||
[(success)
|
||||
(cond
|
||||
[(eq? dep-status 'failure)
|
||||
"brake"]
|
||||
[(eq? test-status 'failure)
|
||||
"yield"]
|
||||
[(eq? min-status 'failure)
|
||||
"ok"]
|
||||
[else "go"])]
|
||||
[else "unknown"])
|
||||
(case status
|
||||
[(failure)
|
||||
(a href: (hash-ref ht 'failure-log)
|
||||
"install fails")]
|
||||
[(success)
|
||||
(define results
|
||||
(append
|
||||
(list
|
||||
(a href: (hash-ref ht 'success-log)
|
||||
"install succeeds"))
|
||||
(case dep-status
|
||||
[(failure)
|
||||
(list
|
||||
(a href: (hash-ref ht 'dep-failure-log)
|
||||
"dependency problems"))]
|
||||
[else null])
|
||||
(case test-status
|
||||
[(failure)
|
||||
(list
|
||||
(a href: (hash-ref ht 'test-failure-log)
|
||||
"test failures"))]
|
||||
[(success)
|
||||
(list
|
||||
(a href: (hash-ref ht 'test-success-log)
|
||||
"no test failures"))]
|
||||
[else null])
|
||||
(case min-status
|
||||
[(failure)
|
||||
(list
|
||||
(a href: (hash-ref ht 'min-failure-log)
|
||||
"extra system dependencies"))]
|
||||
[else null])))
|
||||
(if (= 1 (length results))
|
||||
results
|
||||
(list* (car results)
|
||||
" with "
|
||||
(add-between
|
||||
(cdr results)
|
||||
" and with ")))]
|
||||
[(confusion)
|
||||
(list
|
||||
"install both "
|
||||
(a href: (hash-ref ht 'success-log)
|
||||
"succeeds")
|
||||
" and "
|
||||
(a href: (hash-ref ht 'failure-log) "fails"))]
|
||||
[else ""]))
|
||||
(td class: (if conflicts-log "stop" "neutral")
|
||||
(if conflicts-log
|
||||
(a href: (if (conflicts/indirect? conflicts-log)
|
||||
(conflicts/indirect-path conflicts-log)
|
||||
conflicts-log)
|
||||
(if (conflicts/indirect? conflicts-log)
|
||||
"conflicts in dependency"
|
||||
"conflicts"))
|
||||
"")))))
|
||||
|
||||
(define page-headers
|
||||
(style/inline @~a|{
|
||||
.go { background-color: #ccffcc }
|
||||
.ok { background-color: #ccffff }
|
||||
.yield { background-color: #ffffcc }
|
||||
.brake { background-color: #ffeecc }
|
||||
.stop { background-color: #ffcccc }
|
||||
.author { font-size: small; font-weight: normal; }
|
||||
.annotation { font-size: small }
|
||||
}|))
|
||||
|
||||
(void (page #:site page-site
|
||||
#:file "index.html"
|
||||
#:title page-title
|
||||
(html (head (title page-title)
|
||||
page-headers)
|
||||
(body (table summary)))))
|
||||
|
||||
;; Render to "pkg-build", then move up:
|
||||
(call-with-registered-roots
|
||||
(lambda ()
|
||||
(parameterize ([current-directory dest-dir])
|
||||
(render-all))))
|
||||
|
||||
(define sub-dir (build-path dest-dir "pkg-build"))
|
||||
(for ([f (in-list (directory-list sub-dir))])
|
||||
(delete-directory/files f #:must-exist? #f)
|
||||
(rename-file-or-directory (build-path sub-dir f) f))
|
||||
(delete-directory sub-dir))
|
||||
|
|
@ -1,139 +0,0 @@
|
|||
#lang racket/base
|
||||
|
||||
(provide thread/chunk-output
|
||||
wait-chunk-output
|
||||
flush-chunk-output)
|
||||
|
||||
;; Run `thunk` in a thread, capturing output to deliver
|
||||
;; in chunks.
|
||||
(define (thread/chunk-output thunk)
|
||||
(define (make-port e?)
|
||||
(make-output-port (if e?
|
||||
'stderr/chunked
|
||||
'stdout/chunked)
|
||||
always-evt
|
||||
(lambda (bstr s e buffer? break?)
|
||||
(thread-send manager (vector t (subbytes bstr s e) e?))
|
||||
(- e s))
|
||||
void))
|
||||
(define go (make-semaphore))
|
||||
(define t (parameterize ([current-error-port (make-port #t)]
|
||||
[current-output-port (make-port #f)])
|
||||
(thread (lambda ()
|
||||
(semaphore-wait go)
|
||||
(thunk)))))
|
||||
(thread-send manager t)
|
||||
(semaphore-post go)
|
||||
t)
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
(define no-threads-ch (make-channel))
|
||||
|
||||
(define manager
|
||||
(thread
|
||||
(lambda ()
|
||||
(define (show-output t output)
|
||||
(define e (current-error-port))
|
||||
(define o (current-output-port))
|
||||
(define es (hash-ref output t '()))
|
||||
(for ([i (in-list (reverse es))])
|
||||
(write-bytes (cdr i) (if (car i) e o))))
|
||||
(let loop ([output (hash)])
|
||||
(define (do-message msg-evt)
|
||||
(define msg (thread-receive))
|
||||
(cond
|
||||
[(thread? msg) (loop (hash-set output msg null))]
|
||||
[(pair? msg)
|
||||
(define t (car msg))
|
||||
(define s (cdr msg))
|
||||
(cond
|
||||
[(hash-ref output t #f)
|
||||
(show-output t output)
|
||||
(semaphore-post s)
|
||||
(loop (hash-set output t null))]
|
||||
[else
|
||||
(semaphore-post s)
|
||||
(loop output)])]
|
||||
[else
|
||||
(define-values (t o e?) (vector->values msg))
|
||||
(loop (hash-set output t (cons (cons e? o)
|
||||
(hash-ref output t null))))]))
|
||||
(sync/timeout
|
||||
(lambda ()
|
||||
(apply
|
||||
sync
|
||||
(handle-evt (thread-receive-evt) do-message)
|
||||
(if (zero? (hash-count output))
|
||||
(handle-evt (channel-put-evt no-threads-ch (void))
|
||||
(lambda (_)
|
||||
(loop output)))
|
||||
never-evt)
|
||||
(map
|
||||
(lambda (t)
|
||||
(handle-evt
|
||||
t
|
||||
(lambda (_)
|
||||
(show-output t output)
|
||||
(loop (hash-remove output t)))))
|
||||
(hash-keys output))))
|
||||
(handle-evt (thread-receive-evt) do-message))))))
|
||||
|
||||
(define (flush-chunk-output)
|
||||
(define s (make-semaphore))
|
||||
(thread-send manager (cons (current-thread) s))
|
||||
(semaphore-wait s))
|
||||
|
||||
(define (wait-chunk-output)
|
||||
(channel-get no-threads-ch))
|
||||
|
||||
;; --------------------------------------------------
|
||||
|
||||
(module test racket/base
|
||||
(define o (open-output-bytes))
|
||||
(parameterize ([current-output-port o]
|
||||
[current-error-port o])
|
||||
(define-syntax-rule (def id)
|
||||
(define id
|
||||
(dynamic-require (module-path-index-join
|
||||
`(submod "..")
|
||||
(variable-reference->module-path-index
|
||||
(#%variable-reference)))
|
||||
'id)))
|
||||
(def thread/chunk-output)
|
||||
(def flush-chunk-output)
|
||||
(def wait-chunk-output)
|
||||
(define t1 (thread/chunk-output
|
||||
(lambda ()
|
||||
(printf "hi\n")
|
||||
(eprintf "bye\n")
|
||||
(flush-chunk-output)
|
||||
(sync (system-idle-evt))
|
||||
(printf "HI\n")
|
||||
(eprintf "BYE\n"))))
|
||||
(define t2 (thread/chunk-output
|
||||
(lambda ()
|
||||
(printf "hola\n")
|
||||
(eprintf "adios\n")
|
||||
(flush-chunk-output)
|
||||
(sync (system-idle-evt))
|
||||
(printf "HOLA\n")
|
||||
(eprintf "ADIOS\n"))))
|
||||
(wait-chunk-output))
|
||||
(let ([l '("hi\nbye" "hola\nadios")]
|
||||
[s (get-output-string o)]
|
||||
[sa (lambda (a b) (string-append (car a)
|
||||
"\n"
|
||||
(cadr a)
|
||||
"\n"
|
||||
(car b)
|
||||
"\n"
|
||||
(cadr b)
|
||||
"\n"))]
|
||||
[r reverse]
|
||||
[u (lambda (l) (map string-upcase l))])
|
||||
(unless (or (equal? s (sa l (u l)))
|
||||
(equal? s (sa (r l) (u l)))
|
||||
(equal? s (sa (r l) (u (r l))))
|
||||
(equal? s (sa l (u (r l)))))
|
||||
(error "mismatch: " s))))
|
||||
|
|
@ -1,64 +0,0 @@
|
|||
#lang racket/base
|
||||
|
||||
(provide union! find! elect!)
|
||||
|
||||
(define (find! reps key)
|
||||
(define rep-key (hash-ref reps key key))
|
||||
(if (equal? rep-key key)
|
||||
key
|
||||
(let ([rep-key (find! reps rep-key)])
|
||||
(hash-set! reps key rep-key)
|
||||
rep-key)))
|
||||
|
||||
(define (elect! reps key)
|
||||
(define rep-key (find! reps key))
|
||||
(unless (equal? rep-key key)
|
||||
(hash-set! reps rep-key key)
|
||||
(hash-set! reps key key)))
|
||||
|
||||
(define (union! reps a-key b-key)
|
||||
(define rep-a-key (find! reps a-key))
|
||||
(define rep-b-key (find! reps b-key))
|
||||
(unless (equal? rep-a-key rep-b-key)
|
||||
(hash-set! reps rep-b-key rep-a-key))
|
||||
rep-a-key)
|
||||
|
||||
(module+ test
|
||||
(require rackunit)
|
||||
|
||||
(define t1 (make-hash))
|
||||
(void
|
||||
(union! t1 "1" "2")
|
||||
(union! t1 "a" "b")
|
||||
(union! t1 "b" "c")
|
||||
(union! t1 "d" "e")
|
||||
(union! t1 "f" "d")
|
||||
(union! t1 "3" "2")
|
||||
(union! t1 "g" "d")
|
||||
(union! t1 "b" "d"))
|
||||
|
||||
(check-equal? (find! t1 "a") "a")
|
||||
(check-equal? (find! t1 "b") "a")
|
||||
(check-equal? (find! t1 "b") "a")
|
||||
(check-equal? (find! t1 "d") "a")
|
||||
(check-equal? (find! t1 "e") "a")
|
||||
(check-equal? (find! t1 "f") "a")
|
||||
(check-equal? (find! t1 "g") "a")
|
||||
|
||||
(elect! t1 "c")
|
||||
|
||||
(check-equal? (find! t1 "a") "c")
|
||||
(check-equal? (find! t1 "b") "c")
|
||||
(check-equal? (find! t1 "b") "c")
|
||||
(check-equal? (find! t1 "d") "c")
|
||||
(check-equal? (find! t1 "e") "c")
|
||||
(check-equal? (find! t1 "f") "c")
|
||||
(check-equal? (find! t1 "g") "c")
|
||||
|
||||
(check-equal? (find! t1 "1") "3")
|
||||
(check-equal? (find! t1 "2") "3")
|
||||
(check-equal? (find! t1 "3") "3"))
|
||||
|
||||
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user