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

86
collects/mred/prefs.ss
View File

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