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

improved drschemes display of planet requires

Browse Source 
svn: r13534
This commit is contained in:
Robby Findler 2009-02-12 13:07:20 +00:00
parent 0be1c093b3
commit d3ed20934a
6 changed files with 431 additions and 377 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

90
collects/drscheme/drscheme.ss
View File

@ -1,47 +1,55 @@
(module drscheme mzscheme #lang scheme/base
(require "private/key.ss")
(define debugging? (getenv "PLTDRDEBUG")) (require "private/key.ss")
(define install-cm? (and (not debugging?) (define debugging? (getenv "PLTDRDEBUG"))
(getenv "PLTDRCM")))
(define cm-trace? (or (equal? (getenv "PLTDRCM") "trace") (define install-cm? (and (not debugging?)
(equal? (getenv "PLTDRDEBUG") "trace"))) (getenv "PLTDRCM")))
(when debugging? (define cm-trace? (or (equal? (getenv "PLTDRCM") "trace")
(printf "PLTDRDEBUG: installing CM to load/create errortrace zos\n") (equal? (getenv "PLTDRDEBUG") "trace")))
(let-values ([(zo-compile
make-compilation-manager-load/use-compiled-handler
manager-trace-handler)
(parameterize ([current-namespace (make-namespace)]
[use-compiled-file-paths '()])
(values
(dynamic-require 'errortrace/zo-compile 'zo-compile)
(dynamic-require 'compiler/cm 'make-compilation-manager-load/use-compiled-handler)
(dynamic-require 'compiler/cm 'manager-trace-handler)))])
(current-compile zo-compile)
(use-compiled-file-paths (list (build-path "compiled" "errortrace")))
(current-load/use-compiled (make-compilation-manager-load/use-compiled-handler))
(error-display-handler (dynamic-require 'errortrace/errortrace-lib
'errortrace-error-display-handler))
(when cm-trace?
(printf "PLTDRDEBUG: enabling CM tracing\n")
(manager-trace-handler
(λ (x) (display "1: ") (display x) (newline))))))
(when install-cm?
(printf "PLTDRCM: installing compilation manager\n")
(let-values ([(make-compilation-manager-load/use-compiled-handler
manager-trace-handler)
(parameterize ([current-namespace (make-namespace)])
(values
(dynamic-require 'compiler/cm 'make-compilation-manager-load/use-compiled-handler)
(dynamic-require 'compiler/cm 'manager-trace-handler)))])
(current-load/use-compiled (make-compilation-manager-load/use-compiled-handler))
(when cm-trace?
(printf "PLTDRCM: enabling CM tracing\n")
(manager-trace-handler
(λ (x) (display "1: ") (display x) (newline))))))
(dynamic-require 'drscheme/private/drscheme-normal #f)) ;; the flush is only here to ensure that the output is
;; appears when running in cygwin under windows.
(define (flprintf fmt . args)
(apply printf fmt args)
(flush-output))
(when debugging?
(flprintf "PLTDRDEBUG: installing CM to load/create errortrace zos\n")
(let-values ([(zo-compile
make-compilation-manager-load/use-compiled-handler
manager-trace-handler)
(parameterize ([current-namespace (make-base-empty-namespace)]
[use-compiled-file-paths '()])
(values
(dynamic-require 'errortrace/zo-compile 'zo-compile)
(dynamic-require 'compiler/cm 'make-compilation-manager-load/use-compiled-handler)
(dynamic-require 'compiler/cm 'manager-trace-handler)))])
(current-compile zo-compile)
(use-compiled-file-paths (list (build-path "compiled" "errortrace")))
(current-load/use-compiled (make-compilation-manager-load/use-compiled-handler))
(error-display-handler (dynamic-require 'errortrace/errortrace-lib
'errortrace-error-display-handler))
(when cm-trace?
(flprintf "PLTDRDEBUG: enabling CM tracing\n")
(manager-trace-handler
(λ (x) (display "1: ") (display x) (newline) (flush-output))))))
(when install-cm?
(flprintf "PLTDRCM: installing compilation manager\n")
(let-values ([(make-compilation-manager-load/use-compiled-handler
manager-trace-handler)
(parameterize ([current-namespace (make-base-empty-namespace)])
(values
(dynamic-require 'compiler/cm 'make-compilation-manager-load/use-compiled-handler)
(dynamic-require 'compiler/cm 'manager-trace-handler)))])
(current-load/use-compiled (make-compilation-manager-load/use-compiled-handler))
(when cm-trace?
(flprintf "PLTDRCM: enabling CM tracing\n")
(manager-trace-handler
(λ (x) (display "1: ") (display x) (newline) (flush-output))))))
(dynamic-require 'drscheme/private/drscheme-normal #f)

484
collects/drscheme/private/drscheme-normal.ss
View File

@ -1,274 +1,274 @@
#lang mzscheme #lang scheme/base
(require mred (require mred
mzlib/class scheme/class
mzlib/cmdline mzlib/cmdline
scheme/list scheme/list
framework/private/bday) framework/private/bday)
; (current-load text-editor-load-handler) ; (current-load text-editor-load-handler)
(define files-to-open (define files-to-open
(command-line (command-line
(case (system-type) (case (system-type)
[(windows) "DrScheme.exe"] [(windows) "DrScheme.exe"]
[(macosx) "drscheme" #;"DrScheme"] [(macosx) "drscheme" #;"DrScheme"]
[else "drscheme"]) [else "drscheme"])
(current-command-line-arguments) (current-command-line-arguments)
(args filenames filenames))) (args filenames filenames)))
(define icons-bitmap (define icons-bitmap
(let ([icons (collection-path "icons")]) (let ([icons (collection-path "icons")])
(lambda (name) (lambda (name)
(make-object bitmap% (build-path icons name))))) (make-object bitmap% (build-path icons name)))))
;; updates the command-line-arguments with only the files ;; updates the command-line-arguments with only the files
;; to open. See also main.ss. ;; to open. See also main.ss.
(current-command-line-arguments (apply vector files-to-open)) (current-command-line-arguments (apply vector files-to-open))
(define-values (texas-independence-day? halloween?) (define-values (texas-independence-day? halloween?)
(let* ([date (seconds->date (current-seconds))] (let* ([date (seconds->date (current-seconds))]
[month (date-month date)] [month (date-month date)]
[day (date-day date)]) [day (date-day date)])
(values (and (= 3 month) (= 2 day)) (values (and (= 3 month) (= 2 day))
(and (= 10 month) (= 31 day))))) (and (= 10 month) (= 31 day)))))
(define high-color? ((get-display-depth) . > . 8)) (define high-color? ((get-display-depth) . > . 8))
(define special-state #f) (define special-state #f)
(define normal-bitmap #f) ; set by load-magic-images (define normal-bitmap #f) ; set by load-magic-images
(define-struct magic-image (chars filename bitmap)) (define-struct magic-image (chars filename [bitmap #:mutable]))
(define (magic-img str img) (define (magic-img str img)
(make-magic-image (reverse (string->list str)) img #f)) (make-magic-image (reverse (string->list str)) img #f))
;; magic strings and their associated images. There should not be a string ;; magic strings and their associated images. There should not be a string
;; in this list that is a prefix of another. ;; in this list that is a prefix of another.
(define magic-images (define magic-images
(list (magic-img "larval" "PLT-206-larval.png") (list (magic-img "larval" "PLT-206-larval.png")
(magic-img "mars" "PLT-206-mars.jpg"))) (magic-img "mars" "PLT-206-mars.jpg")))
(define (load-magic-images) (define (load-magic-images)
(set! load-magic-images void) ; run only once (set! load-magic-images void) ; run only once
(unless normal-bitmap (set! normal-bitmap (icons-bitmap "PLT-206.png"))) (unless normal-bitmap (set! normal-bitmap (icons-bitmap "PLT-206.png")))
(for-each (λ (magic-image) (for-each (λ (magic-image)
(unless (magic-image-bitmap magic-image) (unless (magic-image-bitmap magic-image)
(set-magic-image-bitmap! (set-magic-image-bitmap!
magic-image magic-image
(icons-bitmap (magic-image-filename magic-image))))) (icons-bitmap (magic-image-filename magic-image)))))
magic-images)) magic-images))
(define longest-magic-string (define longest-magic-string
(apply max (map (λ (s) (length (magic-image-chars s))) magic-images))) (apply max (map (λ (s) (length (magic-image-chars s))) magic-images)))
(define key-codes null) (define key-codes null)
(define (find-magic-image) (define (find-magic-image)
(define (prefix? l1 l2) (define (prefix? l1 l2)
(or (null? l1) (or (null? l1)
(and (pair? l2) (and (pair? l2)
(eq? (car l1) (car l2)) (eq? (car l1) (car l2))
(prefix? (cdr l1) (cdr l2))))) (prefix? (cdr l1) (cdr l2)))))
(ormap (λ (i) (and (prefix? (magic-image-chars i) key-codes) i)) (ormap (λ (i) (and (prefix? (magic-image-chars i) key-codes) i))
magic-images)) magic-images))
(define (add-key-code new-code) (define (add-key-code new-code)
(set! key-codes (cons new-code key-codes)) (set! key-codes (cons new-code key-codes))
(when ((length key-codes) . > . longest-magic-string) (when ((length key-codes) . > . longest-magic-string)
(set! key-codes (take key-codes longest-magic-string)))) (set! key-codes (take key-codes longest-magic-string))))
(let ([set-splash-bitmap (let ([set-splash-bitmap
(dynamic-require 'framework/splash 'set-splash-bitmap)]) (dynamic-require 'framework/splash 'set-splash-bitmap)])
((dynamic-require 'framework/splash 'set-splash-char-observer) ((dynamic-require 'framework/splash 'set-splash-char-observer)
(λ (evt) (λ (evt)
(let ([ch (send evt get-key-code)]) (let ([ch (send evt get-key-code)])
(when (char? ch) (when (char? ch)
;; as soon as something is typed, load the bitmaps ;; as soon as something is typed, load the bitmaps
(load-magic-images) (load-magic-images)
(add-key-code ch) (add-key-code ch)
(let ([match (find-magic-image)]) (let ([match (find-magic-image)])
(when match (when match
(set! key-codes null) (set! key-codes null)
(set-splash-bitmap (set-splash-bitmap
(if (eq? special-state match) (if (eq? special-state match)
(begin (set! special-state #f) normal-bitmap) (begin (set! special-state #f) normal-bitmap)
(begin (set! special-state match) (begin (set! special-state match)
(magic-image-bitmap match))))))))))) (magic-image-bitmap match)))))))))))
(when (eb-bday?) (when (eb-bday?)
(let () (let ()
(define main-size 260) (define main-size 260)
(define pi (atan 0 -1)) (define pi (atan 0 -1))
(define eli (icons-bitmap "eli-purple.jpg")) (define eli (icons-bitmap "eli-purple.jpg"))
(define bitmap (make-object bitmap% main-size main-size)) (define bitmap (make-object bitmap% main-size main-size))
(define bdc (make-object bitmap-dc% bitmap)) (define bdc (make-object bitmap-dc% bitmap))
(define outer-color (send the-color-database find-color "darkorange")) (define outer-color (send the-color-database find-color "darkorange"))
(define inner-color (send the-color-database find-color "green")) (define inner-color (send the-color-database find-color "green"))
(define omega-str "(λ (x) (x x)) (λ (x) (x x)) ") (define omega-str "(λ (x) (x x)) (λ (x) (x x)) ")
(define hebrew-str " ףוס ןיא ףוס ןיא") (define hebrew-str " ףוס ןיא ףוס ןיא")
(define (draw-letter dc cx cy angle radius letter color) (define (draw-letter dc cx cy angle radius letter color)
(let ([x (+ cx (* (cos angle) radius))] (let ([x (+ cx (* (cos angle) radius))]
[y (- cy (* (sin angle) radius))]) [y (- cy (* (sin angle) radius))])
(send bdc set-text-foreground color) (send bdc set-text-foreground color)
(send dc draw-text letter x y #f 0 (- angle (/ pi 2))))) (send dc draw-text letter x y #f 0 (- angle (/ pi 2)))))
(define (draw-single-loop str dc offset cx cy radius font-size color) (define (draw-single-loop str dc offset cx cy radius font-size color)
(send dc set-font (send the-font-list find-or-create-font font-size 'modern)) (send dc set-font (send the-font-list find-or-create-font font-size 'modern))
(let loop ([i (string-length str)]) (let loop ([i (string-length str)])
(unless (zero? i) (unless (zero? i)
(draw-letter dc (draw-letter dc
cx cx
cy cy
(normalize-angle (normalize-angle
(+ (- (* 2 pi) (* (* 2 pi) (/ (- i 1) (string-length str)))) (+ (- (* 2 pi) (* (* 2 pi) (/ (- i 1) (string-length str))))
(/ pi 2) (/ pi 2)
offset)) offset))
radius radius
(string (string-ref str (- i 1))) (string (string-ref str (- i 1)))
color) color)
(loop (- i 1))))) (loop (- i 1)))))
(define (normalize-angle angle) (define (normalize-angle angle)
(cond (cond
[(<= 0 angle (* 2 pi)) angle] [(<= 0 angle (* 2 pi)) angle]
[(< angle 0) (normalize-angle (+ angle (* 2 pi)))] [(< angle 0) (normalize-angle (+ angle (* 2 pi)))]
[else (normalize-angle (- angle (* 2 pi)))])) [else (normalize-angle (- angle (* 2 pi)))]))
(define splash-canvas ((dynamic-require 'framework/splash 'get-splash-canvas))) (define splash-canvas ((dynamic-require 'framework/splash 'get-splash-canvas)))
(define (draw-single-step dc offset) (define (draw-single-step dc offset)
(send bdc draw-bitmap eli 0 0) (send bdc draw-bitmap eli 0 0)
(draw-single-loop omega-str bdc offset (/ main-size 2) (/ main-size 2) 120 32 outer-color) (draw-single-loop omega-str bdc offset (/ main-size 2) (/ main-size 2) 120 32 outer-color)
(draw-single-loop hebrew-str bdc (+ (- (* 2 pi) offset) (* 2 pi)) (/ main-size 2) (/ main-size 2) 70 20 inner-color) (draw-single-loop hebrew-str bdc (+ (- (* 2 pi) offset) (* 2 pi)) (/ main-size 2) (/ main-size 2) 70 20 inner-color)
(send splash-canvas on-paint)) (send splash-canvas on-paint))
(define gc-b (define gc-b
(with-handlers ([exn:fail? (lambda (x) (with-handlers ([exn:fail? (lambda (x)
(printf "~s\n" (exn-message x)) (printf "~s\n" (exn-message x))
#f)]) #f)])
(let ([b (icons-bitmap "recycle.gif")]) (let ([b (icons-bitmap "recycle.gif")])
(cond (cond
[(send b ok?) [(send b ok?)
(let ([gbdc (make-object bitmap-dc% b)] (let ([gbdc (make-object bitmap-dc% b)]
[ebdc (make-object bitmap-dc% eli)] [ebdc (make-object bitmap-dc% eli)]
[color1 (make-object color%)] [color1 (make-object color%)]
[color2 (make-object color%)] [color2 (make-object color%)]
[avg (lambda (x y) (floor (* (/ x 255) y)))] [avg (lambda (x y) (floor (* (/ x 255) y)))]
[ox (floor (- (/ main-size 2) (/ (send b get-width) 2)))] [ox (floor (- (/ main-size 2) (/ (send b get-width) 2)))]
[oy (floor (- (/ main-size 2) (/ (send b get-height) 2)))]) [oy (floor (- (/ main-size 2) (/ (send b get-height) 2)))])
(let loop ([i (send b get-width)]) (let loop ([i (send b get-width)])
(unless (zero? i) (unless (zero? i)
(let loop ([j (send b get-height)]) (let loop ([j (send b get-height)])
(unless (zero? j) (unless (zero? j)
(let ([x (- i 1)] (let ([x (- i 1)]
[y (- j 1)]) [y (- j 1)])
(send gbdc get-pixel x y color1) (send gbdc get-pixel x y color1)
(send ebdc get-pixel (+ x ox) (+ y oy) color2) (send ebdc get-pixel (+ x ox) (+ y oy) color2)
(send color1 set (send color1 set
(avg (send color1 red) (send color2 red)) (avg (send color1 red) (send color2 red))
(avg (send color1 green) (send color2 green)) (avg (send color1 green) (send color2 green))
(avg (send color1 blue) (send color2 blue))) (avg (send color1 blue) (send color2 blue)))
(send gbdc set-pixel x y color1) (send gbdc set-pixel x y color1)
(loop (- j 1))))) (loop (- j 1)))))
(loop (- i 1)))) (loop (- i 1))))
(send gbdc set-bitmap #f) (send gbdc set-bitmap #f)
(send ebdc set-bitmap #f) (send ebdc set-bitmap #f)
b)] b)]
[else #f])))) [else #f]))))
(define (eli-paint dc) (define (eli-paint dc)
(send dc draw-bitmap bitmap 0 0)) (send dc draw-bitmap bitmap 0 0))
(define (eli-event evt) (define (eli-event evt)
(cond (cond
[(send evt leaving?) [(send evt leaving?)
((dynamic-require 'framework/splash 'set-splash-paint-callback) orig-paint) ((dynamic-require 'framework/splash 'set-splash-paint-callback) orig-paint)
(when gc-b (when gc-b
(unregister-collecting-blit splash-canvas)) (unregister-collecting-blit splash-canvas))
(send splash-canvas refresh) (send splash-canvas refresh)
(when draw-thread (when draw-thread
(kill-thread draw-thread) (kill-thread draw-thread)
(set! draw-thread #f))] (set! draw-thread #f))]
[(send evt entering?) [(send evt entering?)
((dynamic-require 'framework/splash 'set-splash-paint-callback) eli-paint) ((dynamic-require 'framework/splash 'set-splash-paint-callback) eli-paint)
(when gc-b (when gc-b
(register-collecting-blit splash-canvas (register-collecting-blit splash-canvas
(floor (- (/ main-size 2) (floor (- (/ main-size 2)
(/ (send gc-b get-width) 2))) (/ (send gc-b get-width) 2)))
(floor (- (/ main-size 2) (floor (- (/ main-size 2)
(/ (send gc-b get-height) 2))) (/ (send gc-b get-height) 2)))
(send gc-b get-width) (send gc-b get-width)
(send gc-b get-height) (send gc-b get-height)
gc-b gc-b)) gc-b gc-b))
(send splash-canvas refresh) (send splash-canvas refresh)
(unless draw-thread (unless draw-thread
(start-thread))])) (start-thread))]))
(define splash-eventspace ((dynamic-require 'framework/splash 'get-splash-eventspace))) (define splash-eventspace ((dynamic-require 'framework/splash 'get-splash-eventspace)))
(define draw-next-state (define draw-next-state
(let ([o 0]) (let ([o 0])
(lambda () (lambda ()
(let ([s (make-semaphore 0)]) (let ([s (make-semaphore 0)])
(parameterize ([current-eventspace splash-eventspace]) (parameterize ([current-eventspace splash-eventspace])
(queue-callback (queue-callback
(λ ()
(draw-single-step bdc o)
(semaphore-post s))))
(semaphore-wait s))
(let ([next (+ o (/ pi 60))])
(set! o (if (< next (* 2 pi))
next
(- next (* 2 pi))))))))
(define draw-thread #f)
(define (start-thread)
(set! draw-thread
(thread
(λ () (λ ()
(let loop () (draw-single-step bdc o)
(draw-next-state) (semaphore-post s))))
(sleep .01) (semaphore-wait s))
(loop)))))) (let ([next (+ o (/ pi 60))])
(define orig-paint ((dynamic-require 'framework/splash 'get-splash-paint-callback))) (set! o (if (< next (* 2 pi))
next
(- next (* 2 pi))))))))
(draw-next-state) (define draw-thread #f)
((dynamic-require 'framework/splash 'set-splash-event-callback) eli-event) (define (start-thread)
(send splash-canvas refresh))) (set! draw-thread
(thread
(λ ()
(let loop ()
(draw-next-state)
(sleep .01)
(loop))))))
(define orig-paint ((dynamic-require 'framework/splash 'get-splash-paint-callback)))
((dynamic-require 'framework/splash 'start-splash) (draw-next-state)
(build-path (collection-path "icons") ((dynamic-require 'framework/splash 'set-splash-event-callback) eli-event)
(cond (send splash-canvas refresh)))
[texas-independence-day?
"texas-plt-bw.gif"]
[(and halloween? high-color?)
"PLT-pumpkin.png"]
[high-color? "PLT-206.png"]
[(= (get-display-depth) 1)
"pltbw.gif"]
[else
"plt-flat.gif"]))
"DrScheme"
99)
(when (getenv "PLTDRBREAK") ((dynamic-require 'framework/splash 'start-splash)
(printf "PLTDRBREAK: creating break frame\n") (build-path (collection-path "icons")
(let ([to-break (eventspace-handler-thread (current-eventspace))]) (cond
(parameterize ([current-eventspace (make-eventspace)]) [texas-independence-day?
(let* ([f (new frame% (label "Break DrScheme"))] "texas-plt-bw.gif"]
[b (new button% [(and halloween? high-color?)
(label "Break Main Thread") "PLT-pumpkin.png"]
(callback [high-color? "PLT-206.png"]
(λ (x y) [(= (get-display-depth) 1)
(break-thread to-break))) "pltbw.gif"]
(parent f))] [else
[b (new button% "plt-flat.gif"]))
(label "Break All Threads") "DrScheme"
(callback 99)
(λ (x y)
((dynamic-require 'drscheme/private/key 'break-threads))))
(parent f))])
(send f show #t)))))
(dynamic-require 'drscheme/tool-lib #f) (when (getenv "PLTDRBREAK")
(printf "PLTDRBREAK: creating break frame\n") (flush-output)
(let ([to-break (eventspace-handler-thread (current-eventspace))])
(parameterize ([current-eventspace (make-eventspace)])
(let* ([f (new frame% (label "Break DrScheme"))]
[b (new button%
(label "Break Main Thread")
(callback
(λ (x y)
(break-thread to-break)))
(parent f))]
[b (new button%
(label "Break All Threads")
(callback
(λ (x y)
((dynamic-require 'drscheme/private/key 'break-threads))))
(parent f))])
(send f show #t)))))
(dynamic-require 'drscheme/tool-lib #f)

32
collects/drscheme/private/rep.ss
View File

@ -1297,11 +1297,11 @@ TODO
;; register drscheme with the planet-terse-register for the user's namespace ;; register drscheme with the planet-terse-register for the user's namespace
;; must be called after 'initialize-parameters' is called (since it initializes ;; must be called after 'initialize-parameters' is called (since it initializes
;; the user's namespace) ;; the user's namespace)
(planet-terse-set-key (gensym))
(planet-terse-register (planet-terse-register
(lambda (tag package) (lambda (tag package)
(parameterize ([current-eventspace drscheme:init:system-eventspace]) (parameterize ([current-eventspace drscheme:init:system-eventspace])
(queue-callback (λ () (new-planet-info tag package))))) (queue-callback (λ () (new-planet-info tag package))))))
(get-user-namespace))
;; disable breaks until an evaluation actually occurs ;; disable breaks until an evaluation actually occurs
(send context set-breakables #f #f) (send context set-breakables #f #f)
@ -1438,33 +1438,35 @@ TODO
(define logger-messages '()) (define logger-messages '())
(define/public (get-logger-messages) logger-messages) (define/public (get-logger-messages) logger-messages)
(define/private (new-log-message vec) (define/private (new-log-message vec)
(let ([level (vector-ref vec 0)] (let* ([level (vector-ref vec 0)]
[str (cond [str (cond
[(<= (string-length (vector-ref vec 1)) log-entry-max-size) [(<= (string-length (vector-ref vec 1)) log-entry-max-size)
(vector-ref vec 1)] (vector-ref vec 1)]
[else [else
(substring (vector-ref vec 1) 0 log-entry-max-size)])]) (substring (vector-ref vec 1) 0 log-entry-max-size)])]
[msg (vector level str)])
(cond (cond
[(< (length logger-messages) log-max-size) [(< (length logger-messages) log-max-size)
(set! logger-messages (cons (vector level str) logger-messages))] (set! logger-messages (cons msg logger-messages))
(update-logger-gui (cons 'add-line msg))]
[else [else
(set! logger-messages (set! logger-messages
(cons (cons
(vector level str) msg
(let loop ([msgs logger-messages]) (let loop ([msgs logger-messages])
(cond (cond
[(null? (cdr msgs)) null] [(null? (cdr msgs)) null]
[else (cons (car msgs) (loop (cdr msgs)))]))))]) [else (cons (car msgs) (loop (cdr msgs)))]))))
(update-logger-gui))) (update-logger-gui (cons 'clear-last-line-and-add-line msg))])))
(define/private (reset-logger-messages) (define/private (reset-logger-messages)
(set! logger-messages '()) (set! logger-messages '())
(update-logger-gui)) (update-logger-gui #f))
(define/private (update-logger-gui) (define/private (update-logger-gui command)
(let ([frame (get-frame)]) (let ([frame (get-frame)])
(when frame (when frame
(send frame update-logger-window)))) (send frame update-logger-window command))))
(define/private (new-planet-info tag package) (define/private (new-planet-info tag package)
(let ([frame (get-frame)]) (let ([frame (get-frame)])

4
collects/drscheme/private/tools.ss
View File

@ -117,7 +117,7 @@
(define candidate-tool? (define candidate-tool?
(cond (cond
[(getenv "PLTNOTOOLS") [(getenv "PLTNOTOOLS")
(printf "PLTNOTOOLS: skipping tools\n") (printf "PLTNOTOOLS: skipping tools\n") (flush-output)
(lambda (it) #f)] (lambda (it) #f)]
[(getenv "PLTONLYTOOL") => [(getenv "PLTONLYTOOL") =>
(lambda (onlys) (lambda (onlys)
@ -130,7 +130,7 @@
(let-values ([(base name dir) (split-path x)]) (let-values ([(base name dir) (split-path x)])
(memq (string->symbol (path->string name)) (memq (string->symbol (path->string name))
allowed)))]) allowed)))])
(printf "PLTONLYTOOL: only loading ~s\n" allowed) (printf "PLTONLYTOOL: only loading ~s\n" allowed) (flush-output)
(lambda (it) (lambda (it)
(directory-ok? (directory-ok?
(directory-record-path (directory-record-path

88
collects/drscheme/private/unit.ss
View File

@ -1433,11 +1433,11 @@ module browser threading seems wrong.
(not (member logger-panel l)))) (not (member logger-panel l))))
;; if things are already up to date, only update the logger text ;; if things are already up to date, only update the logger text
(when show? (when show?
(update-logger-window)) (update-logger-window #f))
l] l]
[show? [show?
(new-logger-text) (new-logger-text)
(update-logger-window) (update-logger-window #f)
(send logger-menu-item set-label (string-constant hide-log)) (send logger-menu-item set-label (string-constant hide-log))
(append (remq logger-panel l) (list logger-panel))] (append (remq logger-panel l) (list logger-panel))]
[else [else
@ -1453,11 +1453,11 @@ module browser threading seems wrong.
[parent logger-panel] [parent logger-panel]
[callback [callback
(λ (tp evt) (λ (tp evt)
(update-logger-window))])) (update-logger-window #f))]))
(new-logger-text) (new-logger-text)
(new editor-canvas% [parent logger-gui-tab-panel] [editor logger-gui-text]) (new editor-canvas% [parent logger-gui-tab-panel] [editor logger-gui-text])
(send logger-menu-item set-label (string-constant hide-log)) (send logger-menu-item set-label (string-constant hide-log))
(update-logger-window) (update-logger-window #f)
(send logger-parent-panel change-children (lambda (l) (append l (list logger-panel)))))]) (send logger-parent-panel change-children (lambda (l) (append l (list logger-panel)))))])
(with-handlers ([exn:fail? void]) (with-handlers ([exn:fail? void])
(send logger-parent-panel set-percentages (list p (- 1 p)))) (send logger-parent-panel set-percentages (list p (- 1 p))))
@ -1472,27 +1472,66 @@ module browser threading seems wrong.
(set! logger-gui-text (new (text:hide-caret/selection-mixin text:basic%))) (set! logger-gui-text (new (text:hide-caret/selection-mixin text:basic%)))
(send logger-gui-text lock #t)) (send logger-gui-text lock #t))
(define/public (update-logger-window) (define/public (update-logger-window command)
(when logger-gui-text (when logger-gui-text
(send logger-gui-text begin-edit-sequence) (let ([admin (send logger-gui-text get-admin)]
(send logger-gui-text lock #f) [canvas (send logger-gui-text get-canvas)])
(send logger-gui-text erase) (when (and canvas admin)
(let ([level (case (send logger-gui-tab-panel get-selection) (let ([logger-messages (send interactions-text get-logger-messages)]
[(0) #f] [level (case (send logger-gui-tab-panel get-selection)
[(1) 'fatal] [(0) #f]
[(2) 'error] [(1) 'fatal]
[(3) 'warning] [(2) 'error]
[(4) 'info] [(3) 'warning]
[(5) 'debug])]) [(4) 'info]
(for-each [(5) 'debug])])
(λ (x) (cond
(when (or (not level) [(and (pair? command)
(eq? level (vector-ref x 0))) (pair? logger-messages)
(send logger-gui-text insert "\n" 0 0) ;; just flush and redraw everything if there is one (or zero) logger messages
(send logger-gui-text insert (vector-ref x 1) 0 0))) (pair? (cdr logger-messages)))
(send interactions-text get-logger-messages))) (let ([msg (cdr command)])
(send logger-gui-text lock #t) (when (or (not level)
(send logger-gui-text end-edit-sequence))) (eq? (vector-ref msg 0) level))
(send logger-gui-text begin-edit-sequence)
(send logger-gui-text lock #f)
(case (car command)
[(add-line) (void)]
[(clear-last-and-add-line)
(send logger-gui-text delete
0
(send logger-gui-text paragraph-start-position 1))])
(send logger-gui-text insert
"\n"
(send logger-gui-text last-position)
(send logger-gui-text last-position))
(send logger-gui-text insert
(vector-ref msg 1)
(send logger-gui-text last-position)
(send logger-gui-text last-position))
(send logger-gui-text end-edit-sequence)
(send logger-gui-text lock #t)))]
[else
(send logger-gui-text begin-edit-sequence)
(send logger-gui-text lock #f)
(send logger-gui-text erase)
(let ([insert-one
(λ (x newline?)
(when (or (not level)
(eq? level (vector-ref x 0)))
(when newline? (send logger-gui-text insert "\n" 0 0))
(send logger-gui-text insert (vector-ref x 1) 0 0)))])
(unless (null? logger-messages)
;; skip the last newline in the buffer
(insert-one (car logger-messages) #f)
(for-each
(λ (x) (insert-one x #t))
(cdr (send interactions-text get-logger-messages)))))
(send logger-gui-text lock #t)
(send logger-gui-text end-edit-sequence)]))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ;;
@ -1527,7 +1566,6 @@ module browser threading seems wrong.
[label (string-constant show-log)] [label (string-constant show-log)]
[callback (λ (a b) (send current-tab toggle-log))])) [callback (λ (a b) (send current-tab toggle-log))]))
(update-logger-button-label) (update-logger-button-label)
;; needs to become that little x thingy that is in the search/replace bar
(new close-icon% (new close-icon%
[parent planet-status-panel] [parent planet-status-panel]
[callback (λ () [callback (λ ()

40
collects/planet/terse-info.ss
View File

@ -4,50 +4,56 @@
This file is shared between the original This file is shared between the original
namespace that drscheme first starts with namespace that drscheme first starts with
and other namespaces that it loads, any other namespaces that it loads,
so it keeps the requirements low (it could so it keeps the requirements low (it could
be in the '#%kernel language, but be in the '#%kernel language, but
drscheme already shares mred/mred, so there drscheme already shares mred/mred, so there
seems little point to that. seems little point to that).
|# |#
(provide planet-terse-register planet-terse-log) (provide planet-terse-register
planet-terse-log
planet-terse-set-key)
(define-values (terse-log-message-chan) (make-channel)) (define terse-log-message-chan (make-channel))
(define-values (terse-log-proc-chan) (make-channel)) (define terse-log-proc-chan (make-channel))
(define terse-log-key-param (make-parameter (gensym)))
(define thd (define thd
(thread (thread
(lambda () (lambda ()
(let ([procs (make-weak-hash)]) (let ([procs (make-weak-hasheq)])
(let loop () (let loop ()
(sync (sync
(handle-evt (handle-evt
terse-log-message-chan terse-log-message-chan
(lambda (msg) (lambda (msg)
(let ([namespace (list-ref msg 0)] (let ([registry (list-ref msg 0)]
[id (list-ref msg 1)] [id (list-ref msg 1)]
[str (list-ref msg 2)]) [str (list-ref msg 2)])
(for-each (lambda (eph) (for-each (lambda (eph)
(let ([proc (ephemeron-value eph)]) (let ([proc (ephemeron-value eph)])
(when proc (when proc
(proc id str)))) (proc id str))))
(hash-ref procs namespace '()))) (hash-ref procs registry '())))
(loop))) (loop)))
(handle-evt (handle-evt
terse-log-proc-chan terse-log-proc-chan
(lambda (pn) (lambda (rp)
(let ([proc (list-ref pn 0)] (let ([registry (list-ref rp 0)]
[namespace (list-ref pn 1)]) [proc (list-ref rp 1)])
(hash-update! procs (hash-update! procs
namespace registry
(lambda (x) (cons (make-ephemeron namespace proc) x)) (lambda (x) (cons (make-ephemeron registry proc) x))
'()) '())
(loop)))))))))) (loop))))))))))
(define (planet-terse-log id str [namespace (current-namespace)]) (define (planet-terse-log id str [key (terse-log-key-param)])
(sync (channel-put-evt terse-log-message-chan (list namespace id str)))) (sync (channel-put-evt terse-log-message-chan (list key id str))))
(define (planet-terse-register proc [namespace (current-namespace)]) (define (planet-terse-register proc [key (terse-log-key-param)])
(sync (channel-put-evt terse-log-proc-chan (list proc namespace)))) (sync (channel-put-evt terse-log-proc-chan (list key proc))))
(define (planet-terse-set-key new-key)
(terse-log-key-param new-key))