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

40
collects/drscheme/drscheme.ss
View File

@ -1,20 +1,28 @@
(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"))
(define install-cm? (and (not debugging?)
(getenv "PLTDRCM"))) (getenv "PLTDRCM")))
(define cm-trace? (or (equal? (getenv "PLTDRCM") "trace") (define cm-trace? (or (equal? (getenv "PLTDRCM") "trace")
(equal? (getenv "PLTDRDEBUG") "trace"))) (equal? (getenv "PLTDRDEBUG") "trace")))
(when debugging?
(printf "PLTDRDEBUG: installing CM to load/create errortrace zos\n") ;; 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 (let-values ([(zo-compile
make-compilation-manager-load/use-compiled-handler make-compilation-manager-load/use-compiled-handler
manager-trace-handler) manager-trace-handler)
(parameterize ([current-namespace (make-namespace)] (parameterize ([current-namespace (make-base-empty-namespace)]
[use-compiled-file-paths '()]) [use-compiled-file-paths '()])
(values (values
(dynamic-require 'errortrace/zo-compile 'zo-compile) (dynamic-require 'errortrace/zo-compile 'zo-compile)
@ -26,22 +34,22 @@
(error-display-handler (dynamic-require 'errortrace/errortrace-lib (error-display-handler (dynamic-require 'errortrace/errortrace-lib
'errortrace-error-display-handler)) 'errortrace-error-display-handler))
(when cm-trace? (when cm-trace?
(printf "PLTDRDEBUG: enabling CM tracing\n") (flprintf "PLTDRDEBUG: enabling CM tracing\n")
(manager-trace-handler (manager-trace-handler
(λ (x) (display "1: ") (display x) (newline)))))) (λ (x) (display "1: ") (display x) (newline) (flush-output))))))
(when install-cm? (when install-cm?
(printf "PLTDRCM: installing compilation manager\n") (flprintf "PLTDRCM: installing compilation manager\n")
(let-values ([(make-compilation-manager-load/use-compiled-handler (let-values ([(make-compilation-manager-load/use-compiled-handler
manager-trace-handler) manager-trace-handler)
(parameterize ([current-namespace (make-namespace)]) (parameterize ([current-namespace (make-base-empty-namespace)])
(values (values
(dynamic-require 'compiler/cm 'make-compilation-manager-load/use-compiled-handler) (dynamic-require 'compiler/cm 'make-compilation-manager-load/use-compiled-handler)
(dynamic-require 'compiler/cm 'manager-trace-handler)))]) (dynamic-require 'compiler/cm 'manager-trace-handler)))])
(current-load/use-compiled (make-compilation-manager-load/use-compiled-handler)) (current-load/use-compiled (make-compilation-manager-load/use-compiled-handler))
(when cm-trace? (when cm-trace?
(printf "PLTDRCM: enabling CM tracing\n") (flprintf "PLTDRCM: enabling CM tracing\n")
(manager-trace-handler (manager-trace-handler
(λ (x) (display "1: ") (display x) (newline)))))) (λ (x) (display "1: ") (display x) (newline) (flush-output))))))
(dynamic-require 'drscheme/private/drscheme-normal #f)) (dynamic-require 'drscheme/private/drscheme-normal #f)

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

@ -1,14 +1,14 @@
#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"]
@ -17,38 +17,38 @@
(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)
@ -58,12 +58,12 @@
(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)
@ -72,12 +72,12 @@
(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)
@ -95,7 +95,7 @@
(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))
@ -237,7 +237,7 @@
((dynamic-require 'framework/splash 'set-splash-event-callback) eli-event) ((dynamic-require 'framework/splash 'set-splash-event-callback) eli-event)
(send splash-canvas refresh))) (send splash-canvas refresh)))
((dynamic-require 'framework/splash 'start-splash) ((dynamic-require 'framework/splash 'start-splash)
(build-path (collection-path "icons") (build-path (collection-path "icons")
(cond (cond
[texas-independence-day? [texas-independence-day?
@ -252,8 +252,8 @@
"DrScheme" "DrScheme"
99) 99)
(when (getenv "PLTDRBREAK") (when (getenv "PLTDRBREAK")
(printf "PLTDRBREAK: creating break frame\n") (printf "PLTDRBREAK: creating break frame\n") (flush-output)
(let ([to-break (eventspace-handler-thread (current-eventspace))]) (let ([to-break (eventspace-handler-thread (current-eventspace))])
(parameterize ([current-eventspace (make-eventspace)]) (parameterize ([current-eventspace (make-eventspace)])
(let* ([f (new frame% (label "Break DrScheme"))] (let* ([f (new frame% (label "Break DrScheme"))]
@ -271,4 +271,4 @@
(parent f))]) (parent f))])
(send f show #t))))) (send f show #t)))))
(dynamic-require 'drscheme/tool-lib #f) (dynamic-require 'drscheme/tool-lib #f)

24
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

70
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)]
[level (case (send logger-gui-tab-panel get-selection)
[(0) #f] [(0) #f]
[(1) 'fatal] [(1) 'fatal]
[(2) 'error] [(2) 'error]
[(3) 'warning] [(3) 'warning]
[(4) 'info] [(4) 'info]
[(5) 'debug])]) [(5) 'debug])])
(for-each (cond
(λ (x) [(and (pair? command)
(pair? logger-messages)
;; just flush and redraw everything if there is one (or zero) logger messages
(pair? (cdr logger-messages)))
(let ([msg (cdr command)])
(when (or (not level)
(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) (when (or (not level)
(eq? level (vector-ref x 0))) (eq? level (vector-ref x 0)))
(send logger-gui-text insert "\n" 0 0) (when newline? (send logger-gui-text insert "\n" 0 0))
(send logger-gui-text insert (vector-ref x 1) 0 0))) (send logger-gui-text insert (vector-ref x 1) 0 0)))])
(send interactions-text get-logger-messages)))
(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 lock #t)
(send logger-gui-text end-edit-sequence))) (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))