...
original commit: b42b415bb2f1d69495a73944f2754010b277e48a
This commit is contained in:
Robby Findler
parent
27967a52bb
commit
3b2c376f3a
|
|
@ -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))
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user