improved planet logging and drschemes view of it
svn: r13514
This commit is contained in:
Robby Findler
parent
c491ba9b59
commit
36e903c81f
|
|
@ -185,7 +185,8 @@
|
|||
'(lib "mred/mred.ss")
|
||||
'(lib "mrlib/cache-image-snip.ss")
|
||||
'(lib "mrlib/matrix-snip.ss")
|
||||
'(lib "mzlib/pconvert-prop.ss")))
|
||||
'(lib "mzlib/pconvert-prop.ss")
|
||||
'(lib "planet/terse-info.ss")))
|
||||
|
||||
;; ensure that they are all here.
|
||||
(for-each (λ (x) (dynamic-require x #f)) to-be-copied-module-specs)
|
||||
|
|
|
|||
|
|
@ -1291,13 +1291,17 @@ TODO
|
|||
(semaphore-wait s)
|
||||
(custodian-shutdown-all user-custodian))))])
|
||||
(exit-handler drscheme-exit-handler))
|
||||
(initialize-parameters snip-classes)
|
||||
|
||||
;; register drscheme with the planet-terse-register for this namespace
|
||||
((dynamic-require 'planet/terse-info 'planet-terse-register)
|
||||
(lambda (tag package)
|
||||
(parameterize ([current-eventspace drscheme:init:system-eventspace])
|
||||
(queue-callback (λ () (new-planet-info tag package)))))))))
|
||||
(initialize-parameters snip-classes))))
|
||||
|
||||
|
||||
;; register drscheme with the planet-terse-register for the user's namespace
|
||||
;; must be called after 'initialize-parameters' is called (since it initializes
|
||||
;; the user's namespace)
|
||||
(planet-terse-register
|
||||
(lambda (tag package)
|
||||
(parameterize ([current-eventspace drscheme:init:system-eventspace])
|
||||
(queue-callback (λ () (new-planet-info tag package)))))
|
||||
(get-user-namespace))
|
||||
|
||||
;; disable breaks until an evaluation actually occurs
|
||||
(send context set-breakables #f #f)
|
||||
|
|
|
|||
|
|
@ -614,14 +614,20 @@ state of which procedures are registered (via @scheme[planet-terse-register])
|
|||
is saved in the namespace, making the listening and information producing
|
||||
namespace-specific.
|
||||
|
||||
@defproc[(planet-terse-register [proc (-> (or/c 'download 'install 'finish) string? any/c)]) void?]{
|
||||
@defproc[(planet-terse-register
|
||||
[proc (-> (or/c 'download 'install 'finish) string? any/c)]
|
||||
[namespace namespace? (current-namespace)]) void?]{
|
||||
Registers @scheme[proc] as a function to be called when
|
||||
@scheme[planet-terse-log] is called. Note that @scheme[proc] is called
|
||||
@scheme[planet-terse-log] is called with a matching namespace argument.
|
||||
Note that @scheme[proc] is called
|
||||
asynchronously (ie, on some thread other than the one calling @scheme[planet-terse-register]).
|
||||
}
|
||||
|
||||
@defproc[(planet-terse-log [id (or/c 'download 'install 'finish)] [msg string?]) void?]{
|
||||
@defproc[(planet-terse-log [id (or/c 'download 'install 'finish)]
|
||||
[msg string?]
|
||||
[namespace namespace? (current-namespace)]) void?]{
|
||||
This function is called by PLaneT to announce when things are happening.
|
||||
The namespace passed along is used to identify the procs to notify.
|
||||
}
|
||||
|
||||
@section{Developing Packages for PLaneT}
|
||||
|
|
|
|||
|
|
@ -193,7 +193,7 @@ subdirectory.
|
|||
"private/linkage.ss"
|
||||
"parsereq.ss"
|
||||
|
||||
(prefix x: "terse-info.ss")) ;; just to make the link static; this is actually loaded with dynamic-require
|
||||
"terse-info.ss")
|
||||
|
||||
(provide (rename resolver planet-module-name-resolver)
|
||||
resolve-planet-path
|
||||
|
|
@ -210,14 +210,6 @@ subdirectory.
|
|||
;; if #f, will not install packages and instead give an error
|
||||
(define install? (make-parameter #t))
|
||||
|
||||
;; this calls the terse logger from the current-namespace,
|
||||
;; not the original one when the planet resolver was loaded.
|
||||
(define (planet-terse-log id str)
|
||||
(let ([planet-terse-log
|
||||
(with-handlers ((exn:fail? void)) ;; if the dynamic-require fails, we just don't log anything
|
||||
(dynamic-require 'planet/terse-info 'planet-terse-log))])
|
||||
(planet-terse-log id str)))
|
||||
|
||||
;; =============================================================================
|
||||
;; DIAMOND PROPERTY STUFF
|
||||
;; make sure a module isn't loaded twice with two different versions
|
||||
|
|
@ -431,15 +423,19 @@ subdirectory.
|
|||
(let ([p (lookup-package pkg-spec (UNINSTALLED-PACKAGE-CACHE))])
|
||||
(if (and p (file-exists? (build-path (pkg-path p)
|
||||
(pkg-spec-name pkg-spec))))
|
||||
(success-k
|
||||
;; note: it's a little sloppy that lookup-pkg returns PKG structures,
|
||||
;; since it doesn't actually know whether or not the package is
|
||||
;; installed. hence I have to convert what appears to be an installed
|
||||
;; package into an uninstalled package
|
||||
(make-uninstalled-pkg (build-path (pkg-path p) (pkg-spec-name pkg-spec))
|
||||
pkg-spec
|
||||
(pkg-maj p)
|
||||
(pkg-min p)))
|
||||
(begin
|
||||
(planet-log "found local, uninstalled copy of package at ~a"
|
||||
(build-path (pkg-path p)
|
||||
(pkg-spec-name pkg-spec)))
|
||||
(success-k
|
||||
;; note: it's a little sloppy that lookup-pkg returns PKG structures,
|
||||
;; since it doesn't actually know whether or not the package is
|
||||
;; installed. hence I have to convert what appears to be an installed
|
||||
;; package into an uninstalled package
|
||||
(make-uninstalled-pkg (build-path (pkg-path p) (pkg-spec-name pkg-spec))
|
||||
pkg-spec
|
||||
(pkg-maj p)
|
||||
(pkg-min p))))
|
||||
(failure-k void void (λ (x) x)))))
|
||||
|
||||
;; save-to-uninstalled-pkg-cache! : uninstalled-pkg -> path[file]
|
||||
|
|
@ -478,6 +474,7 @@ subdirectory.
|
|||
[(string? p)
|
||||
;; replace any existing error message with the server download error
|
||||
;; message
|
||||
(planet-log p)
|
||||
(failure-k void void (λ (_) p))])))
|
||||
|
||||
;; get-package-from-server : FULL-PKG-SPEC -> PKG-PROMISE | #f | string[error message]
|
||||
|
|
|
|||
|
|
@ -1,34 +1,53 @@
|
|||
(module terse-info '#%kernel
|
||||
#lang scheme/base
|
||||
|
||||
;; This file is dynamically loaded by drscheme in a (possibly)
|
||||
;; empty namespace (ie possibly no scheme/base module yet)
|
||||
;; and it is dynamically loaded by the planet resolver.
|
||||
#|
|
||||
|
||||
This file is shared between the original
|
||||
namespace that drscheme first starts with
|
||||
and other namespaces that it loads,
|
||||
so it keeps the requirements low (it could
|
||||
be in the '#%kernel language, but
|
||||
drscheme already shares mred/mred, so there
|
||||
seems little point to that.
|
||||
|
||||
|#
|
||||
|
||||
(#%provide planet-terse-register planet-terse-log)
|
||||
(define-values (terse-log-message-chan) (make-channel))
|
||||
(define-values (terse-log-proc-chan) (make-channel))
|
||||
(provide planet-terse-register planet-terse-log)
|
||||
|
||||
(define-values (terse-log-message-chan) (make-channel))
|
||||
(define-values (terse-log-proc-chan) (make-channel))
|
||||
|
||||
(define thd
|
||||
(thread
|
||||
(lambda ()
|
||||
(letrec-values ([(loop)
|
||||
(lambda (procs)
|
||||
(sync
|
||||
(handle-evt
|
||||
terse-log-message-chan
|
||||
(lambda (msg)
|
||||
(for-each (lambda (proc) (proc (car msg) (cdr msg))) procs)
|
||||
(loop procs)))
|
||||
(handle-evt
|
||||
terse-log-proc-chan
|
||||
(lambda (proc)
|
||||
(loop (cons proc procs))))))])
|
||||
(loop '()))))
|
||||
(let ([procs (make-weak-hash)])
|
||||
(let loop ()
|
||||
(sync
|
||||
(handle-evt
|
||||
terse-log-message-chan
|
||||
(lambda (msg)
|
||||
(let ([namespace (list-ref msg 0)]
|
||||
[id (list-ref msg 1)]
|
||||
[str (list-ref msg 2)])
|
||||
(for-each (lambda (eph)
|
||||
(let ([proc (ephemeron-value eph)])
|
||||
(when proc
|
||||
(proc id str))))
|
||||
(hash-ref procs namespace '())))
|
||||
(loop)))
|
||||
(handle-evt
|
||||
terse-log-proc-chan
|
||||
(lambda (pn)
|
||||
(let ([proc (list-ref pn 0)]
|
||||
[namespace (list-ref pn 1)])
|
||||
(hash-update! procs
|
||||
namespace
|
||||
(lambda (x) (cons (make-ephemeron namespace proc) x))
|
||||
'())
|
||||
(loop))))))))))
|
||||
|
||||
(define-values (planet-terse-log)
|
||||
(lambda (id str)
|
||||
(sync (channel-put-evt terse-log-message-chan (cons id str)))))
|
||||
(define (planet-terse-log id str [namespace (current-namespace)])
|
||||
(sync (channel-put-evt terse-log-message-chan (list namespace id str))))
|
||||
|
||||
(define-values (planet-terse-register)
|
||||
(lambda (proc)
|
||||
(sync (channel-put-evt terse-log-proc-chan proc)))))
|
||||
|
||||
(define (planet-terse-register proc [namespace (current-namespace)])
|
||||
(sync (channel-put-evt terse-log-proc-chan (list proc namespace))))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user