changed the strategy of the preferences library in the framework to use a different key at the file.ss level (and thus save the prefs on each call to preferences:set)
svn: r5058
This commit is contained in:
Robby Findler
parent
01d27f8ab3
commit
d47247507f
|
|
@ -1127,28 +1127,33 @@ profile todo:
|
|||
(prof-info-time info)))))))
|
||||
(void))
|
||||
|
||||
;; get-color-value : number number -> (is-a?/c color%)
|
||||
;; returns the profiling color
|
||||
;; for `val' if `max-val' is the largest
|
||||
;; of any profiling amount.
|
||||
(define (get-color-value val max-val)
|
||||
(let* ([color-min (preferences:get 'drscheme:profile:low-color)]
|
||||
[color-max (preferences:get 'drscheme:profile:high-color)]
|
||||
[adjust
|
||||
(case (preferences:get 'drscheme:profile:scale)
|
||||
[(sqrt) sqrt]
|
||||
[(square) (λ (x) (* x x))]
|
||||
[(linear) (λ (x) x)])]
|
||||
[factor (adjust (if (zero? max-val) 0 (/ val max-val)))]
|
||||
[get-rgb-value
|
||||
(λ (sel)
|
||||
(let ([small (sel color-min)]
|
||||
[big (sel color-max)])
|
||||
(inexact->exact (floor (+ (* factor (- big small)) small)))))])
|
||||
(make-object color%
|
||||
(get-rgb-value (λ (x) (send x red)))
|
||||
(get-rgb-value (λ (x) (send x green)))
|
||||
(get-rgb-value (λ (x) (send x blue))))))
|
||||
(define (get-color-value/pref val max-val drscheme:profile:low-color drscheme:profile:high-color drscheme:profile:scale)
|
||||
(let* ([adjust
|
||||
(case drscheme:profile:scale
|
||||
[(sqrt) sqrt]
|
||||
[(square) (λ (x) (* x x))]
|
||||
[(linear) (λ (x) x)])]
|
||||
[factor (adjust (if (zero? max-val) 0 (/ val max-val)))]
|
||||
[get-rgb-value
|
||||
(λ (sel)
|
||||
(let ([small (sel drscheme:profile:low-color)]
|
||||
[big (sel drscheme:profile:high-color)])
|
||||
(inexact->exact (floor (+ (* factor (- big small)) small)))))])
|
||||
(make-object color%
|
||||
(get-rgb-value (λ (x) (send x red)))
|
||||
(get-rgb-value (λ (x) (send x green)))
|
||||
(get-rgb-value (λ (x) (send x blue))))))
|
||||
|
||||
;; get-color-value : number number -> (is-a?/c color%)
|
||||
;; returns the profiling color
|
||||
;; for `val' if `max-val' is the largest
|
||||
;; of any profiling amount.
|
||||
(define (get-color-value val max-val)
|
||||
(get-color-value/pref val
|
||||
max-val
|
||||
(preferences:get 'drscheme:profile:low-color)
|
||||
(preferences:get 'drscheme:profile:high-color)
|
||||
(preferences:get 'drscheme:profile:scale)))
|
||||
|
||||
;; extract-maximum : (listof prof-info) -> number
|
||||
;; gets the maximum value of the currently preferred profiling info.
|
||||
|
|
@ -1877,11 +1882,15 @@ profile todo:
|
|||
(define/override (on-paint)
|
||||
(set! in-on-paint? #t)
|
||||
(let* ([dc (get-dc)]
|
||||
[dummy-pen (send dc get-pen)])
|
||||
[dummy-pen (send dc get-pen)]
|
||||
[drscheme:profile:low-color (preferences:get 'drscheme:profile:low-color)]
|
||||
[drscheme:profile:high-color (preferences:get 'drscheme:profile:high-color)]
|
||||
[drscheme:profile:scale (preferences:get 'drscheme:profile:scale)])
|
||||
(let-values ([(w h) (get-client-size)])
|
||||
(let loop ([n 0])
|
||||
(when (n . <= . w)
|
||||
(send pen set-color (get-color-value n w))
|
||||
(send pen set-color
|
||||
(get-color-value/pref n w drscheme:profile:low-color drscheme:profile:high-color drscheme:profile:scale))
|
||||
(send dc set-pen pen)
|
||||
(send dc draw-line n 0 n h)
|
||||
(send dc set-pen dummy-pen)
|
||||
|
|
|
|||
|
|
@ -92,10 +92,10 @@
|
|||
(lambda (x) (or (not x) (path? x))))
|
||||
(preferences:set-un/marshall
|
||||
'drscheme:multi-file-search:directory
|
||||
(λ (v) (path->string v))
|
||||
(λ (v) (and v (path->string v)))
|
||||
(λ (p) (if (path-string? p)
|
||||
(string->path p)
|
||||
#f)))
|
||||
(string->path p)
|
||||
#f)))
|
||||
|
||||
|
||||
;; open-search-window : search-info -> void
|
||||
|
|
|
|||
|
|
@ -238,19 +238,7 @@
|
|||
", "
|
||||
"@flink preferences:set %"
|
||||
".")
|
||||
(preferences:save
|
||||
(-> boolean?)
|
||||
()
|
||||
"\\rawscm{(preferences:save-user-preferences)} saves the user's preferences to disk,"
|
||||
"potentially marshalling some of the preferences."
|
||||
""
|
||||
"Returns \\scm{\\#f} if saving the preferences fails and \\scm{\\#t} otherwise.")
|
||||
(preferences:silent-save
|
||||
(-> boolean?)
|
||||
()
|
||||
"Same as"
|
||||
"@flink preferences:save"
|
||||
"except that it does not put display a message if it fails.")
|
||||
|
||||
(preferences:restore-defaults
|
||||
(-> void?)
|
||||
()
|
||||
|
|
|
|||
|
|
@ -296,22 +296,8 @@
|
|||
|
||||
(exit:insert-on-callback
|
||||
(λ ()
|
||||
(send (group:get-the-frame-group) on-close-all)
|
||||
(preferences:silent-save) ;; the prefs may have changed as a result of closing the windows...
|
||||
))
|
||||
(send (group:get-the-frame-group) on-close-all)))
|
||||
|
||||
(exit:insert-can?-callback
|
||||
(λ ()
|
||||
(or (preferences:save)
|
||||
(exit-anyway?))))
|
||||
|
||||
(define (exit-anyway?)
|
||||
(gui-utils:get-choice
|
||||
(string-constant still-locked-exit-anyway?)
|
||||
(string-constant yes)
|
||||
(string-constant no)
|
||||
(string-constant drscheme)))
|
||||
|
||||
;; reset these -- they are only for the test suite.
|
||||
;; they do not need to be set across starting up and shutting down
|
||||
;; the application.
|
||||
|
|
|
|||
File diff suppressed because it is too large
Load Diff
|
|
@ -80,8 +80,6 @@
|
|||
set-default
|
||||
set-un/marshall
|
||||
|
||||
save
|
||||
silent-save
|
||||
restore-defaults
|
||||
|
||||
add-panel
|
||||
|
|
|
|||
|
|
@ -105,7 +105,6 @@
|
|||
(preferences:set geometry-key
|
||||
(list (send this get-width) (send this get-height)
|
||||
(send this get-x) (send this get-y)))
|
||||
(preferences:save)
|
||||
(send this show #f))
|
||||
(define/augment (on-close) (close))
|
||||
|
||||
|
|
|
|||
|
|
@ -47,7 +47,6 @@
|
|||
(pref:width (send this get-width))
|
||||
(pref:height (send this get-height))
|
||||
(send widget save-prefs)
|
||||
(preferences:save)
|
||||
(inner (void) on-close))
|
||||
))
|
||||
|
||||
|
|
|
|||
|
|
@ -70,7 +70,6 @@
|
|||
(pref:width (send this get-width))
|
||||
(pref:height (send this get-height))
|
||||
(send widget shutdown)
|
||||
(preferences:save)
|
||||
(inner (void) on-close))
|
||||
|
||||
(override/return-false file-menu:create-new?
|
||||
|
|
|
|||
|
|
@ -11,7 +11,7 @@
|
|||
;; IMPORTANT! All preferences operations outside this
|
||||
;; file should go through the following exports.
|
||||
;; DO NOT use preferences:... elsewhere.
|
||||
(provide get-pref put-pref save-prefs
|
||||
(provide get-pref put-pref
|
||||
show-pref-dialog
|
||||
add-preferences-menu-items)
|
||||
|
||||
|
|
@ -152,9 +152,6 @@
|
|||
(in-preferences-eventspace (lambda ()
|
||||
(preferences:set id val))))
|
||||
|
||||
(define (save-prefs)
|
||||
(in-preferences-eventspace preferences:save))
|
||||
|
||||
(define (add-preferences-menu-items edit-menu)
|
||||
(make-object separator-menu-item% edit-menu)
|
||||
(make-object menu-item% "Preferences" edit-menu
|
||||
|
|
|
|||
|
|
@ -49,7 +49,6 @@
|
|||
(semaphore-wait exit-sema)
|
||||
(set! exit-eventspaces (remq evtsp exit-eventspaces))
|
||||
(when (null? exit-eventspaces)
|
||||
(save-prefs)
|
||||
(prim-exit 0))
|
||||
(semaphore-post exit-sema)))
|
||||
|
||||
|
|
|
|||
|
|
@ -380,7 +380,11 @@ please adhere to these guidelines:
|
|||
;;; preferences
|
||||
(preferences "Preferences")
|
||||
(error-saving-preferences "Error saving preferences: ~a")
|
||||
(error-saving-preferences-title "Error saving preferences")
|
||||
(error-reading-preferences "Error reading preferences")
|
||||
(prefs-file-locked "The preferences file is locked (because the file ~a exists), so your preference change could not be saved. Cancel preference change?")
|
||||
(try-again "Try again") ;; button label
|
||||
(prefs-file-still-locked "The preferences file is still locked (because the file ~a exists), so your preference change will not be saved.")
|
||||
(scheme-prefs-panel-label "Scheme")
|
||||
(warnings-prefs-panel-label "Warnings")
|
||||
(editor-prefs-panel-label "Editing")
|
||||
|
|
|
|||
|
|
@ -1,11 +1,4 @@
|
|||
#|
|
||||
|
||||
add this test:
|
||||
|
||||
|
||||
There shouldn't be any error (but add in a bug that triggers one to be sure!)
|
||||
|
||||
|#
|
||||
(module repl-test mzscheme
|
||||
(require "drscheme-test-util.ss"
|
||||
(lib "class.ss")
|
||||
|
|
@ -55,7 +48,7 @@ There shouldn't be any error (but add in a bug that triggers one to be sure!)
|
|||
|
||||
(define test-data
|
||||
(list
|
||||
|
||||
#|
|
||||
;; basic tests
|
||||
(make-test "1"
|
||||
"1"
|
||||
|
|
@ -514,7 +507,7 @@ There shouldn't be any error (but add in a bug that triggers one to be sure!)
|
|||
#f
|
||||
void
|
||||
void)
|
||||
|
||||
|#
|
||||
; fraction snip test
|
||||
;; this test depends on the state of the 'framework:fraction-snip-style preference
|
||||
;; make sure this preference is set to the default when running this test.
|
||||
|
|
@ -527,7 +520,7 @@ There shouldn't be any error (but add in a bug that triggers one to be sure!)
|
|||
#f
|
||||
void
|
||||
void)
|
||||
|
||||
#|
|
||||
;; should produce a syntax object with a turn-down triangle.
|
||||
(make-test "(write (list (syntax x)))"
|
||||
"({embedded \".#<syntax:1:21>\"})"
|
||||
|
|
@ -753,6 +746,28 @@ There shouldn't be any error (but add in a bug that triggers one to be sure!)
|
|||
#f
|
||||
void
|
||||
void)
|
||||
|
||||
(make-test
|
||||
(string-append
|
||||
"(define p (open-output-string))\n"
|
||||
"(parameterize ([current-error-port p])\n"
|
||||
"(dynamic-wind\n"
|
||||
"void\n"
|
||||
"(lambda ()\n"
|
||||
"((error-display-handler)\n"
|
||||
"\"x\"\n"
|
||||
"(with-handlers ((void values)) (eval '(lambda ())))))\n"
|
||||
"(lambda ()\n"
|
||||
"(display (get-output-string p)))))\n")
|
||||
"x in: (lambda ())"
|
||||
"x in: (lambda ())"
|
||||
"x in: (lambda ())"
|
||||
"x in: (lambda ())"
|
||||
'interactions
|
||||
#f
|
||||
void
|
||||
void)
|
||||
|#
|
||||
))
|
||||
|
||||
(define backtrace-image-string "{bug09.gif}")
|
||||
|
|
|
|||
|
|
@ -49,8 +49,7 @@
|
|||
(lambda (f) (f))
|
||||
(lambda (v) (lambda () v)))
|
||||
(begin0 ((preferences:get ',marshalling-pref-sym))
|
||||
(preferences:set ',marshalling-pref-sym (lambda () 2))
|
||||
(preferences:save))))
|
||||
(preferences:set ',marshalling-pref-sym (lambda () 2)))))
|
||||
(shutdown-mred)
|
||||
(test 'preference-marshalling
|
||||
(check-eq? 2)
|
||||
|
|
@ -79,13 +78,11 @@
|
|||
(check-eq? 'stage1)
|
||||
`(begin (preferences:set-default ',default-test-sym 'default symbol?)
|
||||
(preferences:set ',default-test-sym 'new-value)
|
||||
(preferences:save)
|
||||
'stage1))
|
||||
(shutdown-mred)
|
||||
(test 'preference-no-set-default-stage2
|
||||
(check-eq? 'stage2)
|
||||
`(begin (preferences:save)
|
||||
'stage2))
|
||||
`(begin 'stage2))
|
||||
(shutdown-mred)
|
||||
(test 'preference-no-set-default-stage3
|
||||
(check-eq? 'new-value)
|
||||
|
|
|
|||
|
|
@ -3655,6 +3655,15 @@
|
|||
'd-c-s/attr-4
|
||||
`(,node-r (,node-r (,node-r ,t)))))
|
||||
|
||||
;; NOT YET RELEASED
|
||||
#|
|
||||
|
||||
need a test that will revisit a node a second time (when it already has a wrapper)
|
||||
with a new parent. make sure the new parent is recorded in the parents field
|
||||
so that propagation occurs.
|
||||
|
||||
|#
|
||||
|
||||
|
||||
|
||||
;; test the predicate
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user