diff --git a/collects/drscheme/private/eval.ss b/collects/drscheme/private/eval.ss index af2546f8c2..bb02209e52 100644 --- a/collects/drscheme/private/eval.ss +++ b/collects/drscheme/private/eval.ss @@ -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) diff --git a/collects/drscheme/private/rep.ss b/collects/drscheme/private/rep.ss index dbd03729e9..b616c9cb93 100644 --- a/collects/drscheme/private/rep.ss +++ b/collects/drscheme/private/rep.ss @@ -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) diff --git a/collects/planet/planet.scrbl b/collects/planet/planet.scrbl index e2f312901f..4a455e9040 100644 --- a/collects/planet/planet.scrbl +++ b/collects/planet/planet.scrbl @@ -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} diff --git a/collects/planet/resolver.ss b/collects/planet/resolver.ss index 74d1f92e26..ffe9ca281e 100644 --- a/collects/planet/resolver.ss +++ b/collects/planet/resolver.ss @@ -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] diff --git a/collects/planet/terse-info.ss b/collects/planet/terse-info.ss index b4ca3d05de..1d90c594d1 100644 --- a/collects/planet/terse-info.ss +++ b/collects/planet/terse-info.ss @@ -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))))