diff --git a/collects/framework/private/preferences.ss b/collects/framework/private/preferences.ss index 2811c593..aef2c5c7 100644 --- a/collects/framework/private/preferences.ss +++ b/collects/framework/private/preferences.ss @@ -3,6 +3,7 @@ (require (lib "string-constant.ss" "string-constants") (lib "unitsig.ss") (lib "class.ss") + (lib "file.ss") (lib "class100.ss") "sig.ss" "../prefs-file-sig.ss" @@ -21,6 +22,7 @@ (rename [-read read]) + ;; default-preferences-filename (define default-preferences-filename (build-path (collection-path "defaults") "prefs.ss")) @@ -223,81 +225,96 @@ (hash-table-map preferences marshall-pref) p)) 'truncate 'text))))) + (define (err input msg) + (message-box + (string-constant preferences) + (let* ([max-len 150] + [s1 (format "~s" input)] + [ell "..."] + [s2 (if (<= (string-length s1) max-len) + s1 + (string-append + (substring s1 0 (- max-len + (string-length ell))) + ell))]) + (string-append + (string-constant error-reading-preferences) + "\n" + msg + s2)))) + (define (for-each-pref-in-file parse-pref preferences-filename) (let/ec k - (let ([err - (lambda (input msg) - (message-box - (string-constant preferences) - (let* ([max-len 150] - [s1 (format "~s" input)] - [ell "..."] - [s2 (if (<= (string-length s1) max-len) - s1 - (string-append - (substring s1 0 (- max-len - (string-length ell))) - ell))]) - (string-append - (format (string-constant found-bad-pref) preferences-filename) - "\n" - msg - s2))) - (k #f))]) - (let ([input (with-handlers - ([not-break-exn? - (lambda (exn) - (message-box - (string-constant error-reading-preferences) - (string-append - (string-constant error-reading-preferences) - (format "\n~a" (exn-message exn)))) - (k #f))]) - (call-with-input-file preferences-filename - read - 'text))]) - (if (eof-object? input) - (void) - (let loop ([input input]) - (when (pair? input) - (let ([pre-pref (car input)]) - (if (and (list? pre-pref) - (= 2 (length pre-pref))) - (parse-pref (car pre-pref) (cadr pre-pref)) - (err input (string-constant expected-list-of-length2)))) - (loop (cdr input))))))))) + (let ([input (with-handlers + ([not-break-exn? + (lambda (exn) + (message-box + (string-constant error-reading-preferences) + (string-append + (string-constant error-reading-preferences) + (format "\n~a" (exn-message exn)))) + (k #f))]) + (call-with-input-file preferences-filename read 'text))]) + (if (eof-object? input) + (void) + (for-each-pref-in-sexp input parse-pref))))) + ;; for-each-pref-in-sexp : sexp (symbol TST -> void) -> void + (define (for-each-pref-in-sexp input parse-pref) + (let/ec k + (let loop ([input input]) + (when (pair? input) + (let ([pre-pref (car input)]) + (if (and (list? pre-pref) + (= 2 (length pre-pref))) + (parse-pref (car pre-pref) (cadr pre-pref)) + (begin (err input (string-constant expected-list-of-length2)) + (k #f)))) + (loop (cdr input)))))) ;; read-from-file-to-ht : string hash-table -> void (define (read-from-file-to-ht filename ht) (let* ([parse-pref (lambda (p marshalled) - (let* ([ht-pref (hash-table-get ht p (lambda () #f))] - [unmarshall-struct (hash-table-get marshall-unmarshall p (lambda () #f))]) - (cond - [unmarshall-struct - (set p ((un/marshall-unmarshall unmarshall-struct) marshalled))] - - ;; in this case, assume that no marshalling/unmarshalling - ;; is going to take place with the pref, since an unmarshalled - ;; pref was already there. - [(pref? ht-pref) - (set p marshalled)] - - [(marshalled? ht-pref) - (set-marshalled-data! ht-pref marshalled)] - [(and (not ht-pref) unmarshall-struct) - (set p ((un/marshall-unmarshall unmarshall-struct) marshalled))] - [(not ht-pref) - (hash-table-put! ht p (make-marshalled marshalled))] - [else (error 'prefs.ss "robby error.3: ~a" ht-pref)])))]) + (add-raw-pref-to-ht ht p marshalled))]) (when (file-exists? filename) (for-each-pref-in-file parse-pref filename)))) + ;; add-raw-pref-to-ht : hash-table symbol marshalled-preference -> void + (define (add-raw-pref-to-ht ht p marshalled) + (let* ([ht-pref (hash-table-get ht p (lambda () #f))] + [unmarshall-struct (hash-table-get marshall-unmarshall p (lambda () #f))]) + (cond + [unmarshall-struct + (set p ((un/marshall-unmarshall unmarshall-struct) marshalled))] + + ;; in this case, assume that no marshalling/unmarshalling + ;; is going to take place with the pref, since an unmarshalled + ;; pref was already there. + [(pref? ht-pref) + (set p marshalled)] + + [(marshalled? ht-pref) + (set-marshalled-data! ht-pref marshalled)] + [(and (not ht-pref) unmarshall-struct) + (set p ((un/marshall-unmarshall unmarshall-struct) marshalled))] + [(not ht-pref) + (hash-table-put! ht p (make-marshalled marshalled))] + [else (error 'prefs.ss "robby error.3: ~a" ht-pref)]))) + ;; read : -> void (define (-read) - (read-from-file-to-ht (prefs-file:get-preferences-filename) preferences)) - + (let/ec k + (let ([sexp (get-preference + 'drscheme:preferences + (lambda () + (k #f)))]) + (for-each-pref-in-sexp + sexp + (lambda (p marshalled) + (add-raw-pref-to-ht preferences p marshalled))))) + ;(read-from-file-to-ht (prefs-file:get-preferences-filename) preferences) + ) ;; read in the saved defaults. These should override the ;; values used with set-default. diff --git a/collects/framework/private/text.ss b/collects/framework/private/text.ss index 30189247..fa584a59 100644 --- a/collects/framework/private/text.ss +++ b/collects/framework/private/text.ss @@ -400,47 +400,57 @@ (define/override (get-extent dc x y wb hb db sb lb rb) (cond [(memq 'invisible (get-flags)) - (set/f! wb 0) - (set/f! hb 0)] + (set/f! wb 0)] [else - (set/f! wb (get-count)) - (set/f! hb 1)]) + (set/f! wb (get-count))]) + (set/f! hb 1) (set/f! db 0) (set/f! sb 0) (set/f! lb 0) (set/f! rb 0)) - (define (for-each/sections f str) + (field (cache-function #f)) + + (rename [super-insert insert]) + (define/override (insert s len pos) + (set! cache-function #f) + (super-insert s len pos)) + + ;; for-each/sections : string -> (number number -> void) -> void + (define (for-each/sections make-f str) (let loop ([n (string-length str)] [len 0] [blank? #t]) (cond [(zero? n) - (unless blank? - (f n len))] + (if blank? + (lambda (f) (void)) + (lambda (f) (f n len)))] [else (let ([white? (char-whitespace? (string-ref str (- n 1)))]) (cond [(eq? white? blank?) (loop (- n 1) (+ len 1) blank?)] [else - (unless blank? - (f n len)) - (loop (- n 1) - 1 - (not blank?))]))]))) - + (let ([res (loop (- n 1) 1 (not blank?))]) + (if blank? + res + (lambda (f) + (f n len) + (res f))))]))]))) + (define/override (draw dc x y left top right bottom dx dy draw-caret) (let ([str (get-text 0 (get-count))]) + (unless cache-function + (set! cache-function (for-each/sections str))) (when (<= top y bottom) - (for-each/sections + (cache-function (lambda (start len) (send dc draw-line (+ x start) y (+ x start (- len 1)) - y)) - str)))) + y)))))) (apply super-make-object args))) (define 1-pixel-tab-snip% diff --git a/collects/framework/splash.ss b/collects/framework/splash.ss index ad9632b6..bbd18757 100644 --- a/collects/framework/splash.ss +++ b/collects/framework/splash.ss @@ -1,7 +1,7 @@ (module splash mzscheme (require (lib "class.ss") - (lib "etc.ss") + (lib "file.ss") (lib "mred.ss" "mred")) (provide get-splash-bitmap get-splash-canvas get-splash-eventspace get-dropped-files @@ -20,7 +20,7 @@ (define (start-splash _splash-filename _splash-title width-default) (set! splash-title _splash-title) (set! splash-filename _splash-filename) - (set! splash-max-width (max 1 (splash-get-resource (get-splash-width-resource) width-default))) + (set! splash-max-width (max 1 (splash-get-preference (get-splash-width-preference-name) width-default))) (send gauge set-range splash-max-width) (send splash-frame set-label splash-title) (let/ec k @@ -53,12 +53,13 @@ (define splash-current-width 0) - (define (get-splash-width-resource) (format "~a-splash-max-width" splash-title)) + (define (get-splash-width-preference-name) + (string->symbol (format "plt:~a-splash-max-width" splash-title))) (define splash-max-width 1) (define (close-splash) (unless (= splash-max-width splash-current-width) - (splash-set-resource (get-splash-width-resource) (max 1 splash-current-width))) + (splash-set-preference (get-splash-width-preference-name) (max 1 splash-current-width))) (set! quit-on-close? #f) (when splash-frame (send splash-frame show #f))) @@ -129,13 +130,13 @@ (stretchable-width #f) (stretchable-height #f))) - (define (splash-get-resource name default) - (let ([b (box 0)]) - (if (get-resource "mred" name b #f) - (unbox b) - default))) - (define (splash-set-resource name value) - (write-resource "mred" name value (find-graphical-system-path 'setup-file))) + (define (splash-get-preference name default) + (get-preference + name + (lambda () + default))) + (define (splash-set-preference name value) + (put-preferences (list name) (list value))) (define (splitup-path f) (let*-values ([(absf) (if (relative-path? f)