suzanne.soy/gui
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

fixed debug again and added indents prefs

Browse Source 
original commit: 61339e5b474214c5275ca1ae1b44f4ef81d10c51
This commit is contained in:
Robby Findler 1996-06-21 16:12:42 +00:00
parent 358990f590
commit f841e99836
1 changed files with 51 additions and 35 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

86
collects/mred/prefs.ss
View File

@ -10,7 +10,7 @@
(import ([unit mred:debug : mred:debug^] (import ([unit mred:debug : mred:debug^]
[unit mred:exn : mred:exn^] [unit mred:exn : mred:exn^]
[unit mzlib:function : mzlib:function^])) [unit mzlib:function : mzlib:function^]))
(mred:debug:printf 'invoke "mred:preferences@") (mred:debug:printf 'invoke "mred:preferences@")
(define preferences-filename (define preferences-filename
@ -24,13 +24,26 @@
(define-struct un/marshall (marshall unmarshall)) (define-struct un/marshall (marshall unmarshall))
(define-struct marshalled (data))
(define get-preference-box (define get-preference-box
(lambda (p) (lambda (p)
(hash-table-get preferences p (let ([ans (hash-table-get preferences p
(lambda () (lambda ()
(raise (mred:exn:make-exn:unknown-preference (raise (mred:exn:make-exn:unknown-preference
(format "unknown preference: ~a" p) (format "unknown preference: ~a" p)
((debug-info-handler)))))))) ((debug-info-handler))))))])
(if (marshalled? ans)
(let* ([marshalled (marshalled-data ans)]
[unmarshalled
((un/marshall-unmarshall
(hash-table-get marshall-unmarshall p
(lambda () mzlib:function:identity)))
marshalled)]
[boxed (box unmarshalled)])
(hash-table-put! preferences p boxed)
boxed)
ans))))
(define get-preference (mzlib:function:compose unbox get-preference-box)) (define get-preference (mzlib:function:compose unbox get-preference-box))
@ -65,41 +78,44 @@
(for-each (lambda (x) (apply set-preference x)) (for-each (lambda (x) (apply set-preference x))
defaults))) defaults)))
(define save-user-preferences (define save-user-preferences
(lambda () (let ([marshall-pref
(let ([marshall-pref (lambda (p boxed-value)
(lambda (p boxed-value) (let* ([value (unbox boxed-value)]
(let* ([value (unbox boxed-value)] [marshalled
[marshalled (let/ec k
(let/ec k ((un/marshall-marshall
((un/marshall-marshall (hash-table-get marshall-unmarshall p
(hash-table-get marshall-unmarshall p (lambda ()
(lambda () (k value))))
(k value)))) value))])
value))]) (list p marshalled)))])
(list p marshalled)))]) (lambda ()
(call-with-output-file preferences-filename (call-with-output-file preferences-filename
(lambda (p) (lambda (p)
(write (hash-table-map preferences marshall-pref) p)) (write (hash-table-map preferences marshall-pref) p)
'replace)))) 'replace)))))
(define read-user-preferences (define read-user-preferences
(lambda () (let ([unmarshall-pref
(let ([unmarshall-update (lambda (input)
(lambda (input) (let ([p (mzlib:function:first input)]
(let* ([p (mzlib:function:first input)] [marshalled (mzlib:function:second input)])
[marshalled (mzlib:function:second input)] (let/ec k
[unmarshalled (let* ([not-in-table
(let/ec k (lambda ()
((un/marshall-unmarshall (k (hash-table-put! preferences p (make-marshalled marshalled))))]
(hash-table-get marshall-unmarshall p [ht-pref (hash-table-get preferences p not-in-table)]
(lambda () (k marshalled)))) [unmarshall (hash-table-get marshall-unmarshall p (lambda () mzlib:function:identity))])
marshalled))]) (if (box? ht-pref)
(set-preference p unmarshalled)))]) (set-box! ht-pref (unmarshall marshalled))
(set-marshalled-data! marshalled))))))])
(lambda ()
(when (file-exists? preferences-filename) (when (file-exists? preferences-filename)
(let ([input (call-with-input-file preferences-filename read)]) (let ([input (call-with-input-file preferences-filename read)])
(when (list? input) (when (list? input)
(for-each unmarshall-update input))))))) (for-each unmarshall-pref input)))))))
(define preferences-dialog (define preferences-dialog
(lambda () (lambda ()