From 3b2c376f3ae02efaa678e29693a761b8cadf8589 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Mon, 3 Apr 2000 03:45:07 +0000 Subject: [PATCH] ... original commit: b42b415bb2f1d69495a73944f2754010b277e48a --- collects/framework/prefs.ss | 349 ++++++++++++++++++++---------------- 1 file changed, 197 insertions(+), 152 deletions(-) diff --git a/collects/framework/prefs.ss b/collects/framework/prefs.ss index c5d2c0ba..36273770 100644 --- a/collects/framework/prefs.ss +++ b/collects/framework/prefs.ss @@ -15,9 +15,19 @@ [else ".mred.prefs"]))) (define default-preferences-filename (build-path (collection-path "defaults") "prefs.ss")) + ;; preferences : sym -o> (union marshalled pref) (define preferences (make-hash-table)) + + ;; marshall-unmarshall : sym -o> un/marshall (define marshall-unmarshall (make-hash-table)) + + ;; callbacks : sym -o> (listof (sym TST -> boolean)) (define callbacks (make-hash-table)) + + ;; saved-defaults : sym -o> (union marshalled pref) + (define saved-defaults (make-hash-table)) + + ;; defaults : sym -o> default (define defaults (make-hash-table)) (define-struct un/marshall (marshall unmarshall)) @@ -37,26 +47,26 @@ (with-handlers ([(lambda (x) #t) h]) (thunk))))) - (define unmarshall - (lambda (p marshalled) - (let/ec k - (let* ([data (marshalled-data marshalled)] - [unmarshall-fn (un/marshall-unmarshall (hash-table-get marshall-unmarshall - p - (lambda () (k data))))]) - (guard "unmarshalling" p marshalled - (lambda () (unmarshall-fn data)) - (lambda (exn) - (hash-table-get - defaults - p - (lambda () - (message-box - "No Default" - (format - "no default for ~a" - p)) - (raise exn))))))))) + (define (unmarshall p marshalled) + (let/ec k + (let* ([data (marshalled-data marshalled)] + [unmarshall-fn (un/marshall-unmarshall + (hash-table-get marshall-unmarshall + p + (lambda () (k data))))]) + (guard "unmarshalling" p marshalled + (lambda () (unmarshall-fn data)) + (lambda (exn) + (begin0 + (hash-table-get + defaults + p + (lambda () + (raise exn))) + (message-box (format "Error unmarshalling ~a preference" p) + (if (exn? exn) + (exn-message exn) + (format "~s" exn))))))))) (define get-callbacks (lambda (p) @@ -86,55 +96,54 @@ raise)) (get-callbacks p)))) - (define get - (lambda (p) - (let ([ans (hash-table-get preferences p - (lambda () - (raise (exn:make-unknown-preference - (format "attempted to get unknown preference: ~a" p) - (current-continuation-marks)))))]) - (cond - [(marshalled? ans) - (let* ([default-s - (hash-table-get - defaults p - (lambda () - (error 'get-preference - "no default pref for: ~a~n" - p)))] - [default (default-value default-s)] - [checker (default-checker default-s)] - [unmarshalled (let ([unmarsh (unmarshall p ans)]) - (if (checker unmarsh) - unmarsh - (begin - '(printf "WARNING: ~s rejecting invalid pref ~s in favor of ~s (pred: ~s)~n" - p unmarsh default checker) - default)))] - [pref (if (check-callbacks p unmarshalled) - unmarshalled - default)]) - (hash-table-put! preferences p (make-pref pref)) - pref)] - [(pref? ans) (pref-value ans)] - [else (error 'prefs.ss "robby error.1: ~a" ans)])))) + (define (get p) + (let ([ans (hash-table-get preferences p + (lambda () + (raise (exn:make-unknown-preference + (format "attempted to get unknown preference: ~a" p) + (current-continuation-marks)))))]) + (cond + [(marshalled? ans) + (let* ([default-s + (hash-table-get + defaults p + (lambda () + (error 'preferences:get + "no default pref for: ~a~n" + p)))] + [default (default-value default-s)] + [checker (default-checker default-s)] + [unmarshalled (let ([unmarsh (unmarshall p ans)]) + (if (checker unmarsh) + unmarsh + default))] + [pref (if (check-callbacks p unmarshalled) + unmarshalled + default)]) + (hash-table-put! preferences p (make-pref pref)) + pref)] + [(pref? ans) + (pref-value ans)] + [else (error 'prefs.ss "robby error.1: ~a" ans)]))) - (define set - (lambda (p value) - (let* ([pref (hash-table-get preferences p (lambda () #f))]) - (cond - [(pref? pref) - (when (check-callbacks p value) - (set-pref-value! pref value))] - [(or (marshalled? pref) - (not pref)) - (when (check-callbacks p value) - (hash-table-put! preferences p (make-pref value)))] - [else - (error 'prefs.ss "robby error.0: ~a" pref)])))) + (define (set p value) + (let* ([pref (hash-table-get preferences p (lambda () #f))]) + (cond + [(pref? pref) + (when (check-callbacks p value) + (set-pref-value! pref value))] + [(or (marshalled? pref) + (not pref)) + (when (check-callbacks p value) + (hash-table-put! preferences p (make-pref value)))] + [else + (error 'prefs.ss "robby error.0: ~a" pref)]))) (define set-un/marshall (lambda (p marshall unmarshall) + (when (hash-table-get defaults p (lambda () #f)) + (error 'set-un/marshall "must call set-default for ~s before calling set-un/marshall for ~s" + p p)) (hash-table-put! marshall-unmarshall p (make-un/marshall marshall unmarshall)))) (define restore-defaults @@ -143,15 +152,39 @@ defaults (lambda (p v) (set p v))))) - (define set-default - (lambda (p value checker) - (let ([t (checker value)]) - (unless t - (error 'set-default "~s: checker (~s) returns ~s for ~s, expected #t~n" p checker t value))) + ;; set-default : (sym TST (TST -> boolean) -> void + (define (set-default p in-default-value checker) + (let* ([default-value + (let/ec k + (let ([saved-default + (hash-table-get saved-defaults p (lambda () + (k in-default-value)))]) + (cond + [(marshalled? saved-default) + (let* ([unmarsh (unmarshall p saved-default)] + [unmarshalled + (if (checker unmarsh) + unmarsh + (begin + '(printf + "WARNING: rejected saved default ~s for ~s; using ~s instead" + unmarsh p in-default-value) + in-default-value))] + [pref (if (check-callbacks p unmarshalled) + unmarshalled + in-default-value)]) + (hash-table-put! saved-defaults p (make-pref pref)) + pref)] + [(pref? saved-default) + (pref-value saved-default)])))] + [default-okay? (checker default-value)]) + (unless default-okay? + (error 'set-default "~s: checker (~s) returns ~s for ~s, expected #t~n" + p checker default-okay? default-value)) (hash-table-get preferences p - (lambda () - (hash-table-put! preferences p (make-pref value)))) - (hash-table-put! defaults p (make-default value checker)))) + (lambda () + (hash-table-put! preferences p (make-pref default-value)))) + (hash-table-put! defaults p (make-default default-value checker)))) (define save (let ([marshall-pref @@ -183,88 +216,100 @@ (mzlib:pretty-print:pretty-print (hash-table-map preferences marshall-pref) p)) 'truncate 'text))))) + + (define (for-each-pref-in-file parse-pref preferences-filename) + (let/ec k + (let ([err + (lambda (input msg) + (message-box "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))]) + (format "found bad pref in ~a: ~a~n~a" + preferences-filename msg s2))))]) + (let ([input (with-handlers + ([(lambda (exn) #t) + (lambda (exn) + (message-box + "Error reading preferences" + (format "Error reading preferences~n~a" + (exn-message exn))) + (k #f))]) + (call-with-input-file preferences-filename + read + 'text))]) + (let loop ([input input]) + (cond + [(pair? input) + (let ([err-msg + (let/ec k + (let ([first (car input)]) + (unless (pair? first) + (k "expected pair of pair")) + (let ([arg1 (car first)] + [t1 (cdr first)]) + (unless (pair? t1) + (k "expected pair of two pairs")) + (let ([arg2 (car t1)] + [t2 (cdr t1)]) + (unless (null? t2) + (k "expected null after two pairs")) + (parse-pref arg1 arg2) + (k #f)))))]) + (when err-msg + (err input err-msg))) + (loop (cdr input))] + [(null? input) (void)] + [else (err input "expected a pair")])))))) - (define -read + ;; read-from-file-to-ht : string hash-table -> void + (define (read-from-file-to-ht filename ht) (let* ([parse-pref (lambda (p marshalled) - (let/ec k - (let* ([ht-pref (hash-table-get preferences 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! preferences p (make-marshalled marshalled))] - [else (error 'prefs.ss "robby error.3: ~a" ht-pref)]))))] - [read-from-filename - (lambda (preferences-filename) - (let/ec k - (let ([err - (lambda (input msg) - (message-box "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))]) - (format "found bad pref in ~a: ~a~n~a" - preferences-filename msg s2))))]) - (let ([input (with-handlers - ([(lambda (exn) #t) - (lambda (exn) - (message-box - "Error reading preferences" - (format "Error reading preferences~n~a" - (exn-message exn))) - (k #f))]) - (call-with-input-file preferences-filename - read - 'text))]) - (let loop ([input input]) - (cond - [(pair? input) - (let ([err-msg - (let/ec k - (let ([first (car input)]) - (unless (pair? first) - (k "expected pair of pair")) - (let ([arg1 (car first)] - [t1 (cdr first)]) - (unless (pair? t1) - (k "expected pair of two pairs")) - (let ([arg2 (car t1)] - [t2 (cdr t1)]) - (unless (null? t2) - (k "expected null after two pairs")) - (parse-pref arg1 arg2) - (k #f)))))]) - (when err-msg - (err input err-msg))) - (loop (cdr input))] - [(null? input) (void)] - [else (err input "expected a pair")]))))))]) - (lambda () - (cond - [(file-exists? preferences-filename) - (read-from-filename preferences-filename)] - [(file-exists? default-preferences-filename) - (read-from-filename default-preferences-filename)] - [else (void)])))) + (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)])))]) + (when (file-exists? filename) + (for-each-pref-in-file parse-pref filename)))) + + ;; read : -> void + (define (-read) + (read-from-file-to-ht preferences-filename preferences)) + + + ;; read in the saved defaults. These should override the + ;; values used with set-default. + (read-from-file-to-ht default-preferences-filename saved-defaults) + + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;; ;;; + ;;; preferences dialog ;;; + ;;; ;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (define-struct ppanel (title container panel))