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

new preferences dialog

Browse Source 
original commit: 76d05fd5eaf7feb26cca55cb44e4aa8e37216b9a
This commit is contained in:
Robby Findler 1996-07-09 21:57:26 +00:00
parent ecae9710d5
commit 8577dec657
1 changed files with 85 additions and 70 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

155
collects/mred/prefs.ss
View File

@ -6,6 +6,8 @@
[mred:exn : mred:exn^] [mred:exn : mred:exn^]
[mred : mred:container^] ;; warning -- to use the mred:panel macros, [mred : mred:container^] ;; warning -- to use the mred:panel macros,
;; need to have mred:container be prefixed with "mred" ;; need to have mred:container be prefixed with "mred"
[mred:exit : mred:exit^]
[mred:gui-utils : mred:gui-utils^]
[mred:edit : mred:edit^] [mred:edit : mred:edit^]
[mzlib:function : mzlib:function^]) [mzlib:function : mzlib:function^])
@ -31,18 +33,20 @@
(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) (cond
(let* ([marshalled (marshalled-data ans)] [(marshalled? ans)
[unmarshalled (let* ([marshalled (marshalled-data ans)]
(let/ec k [unmarshalled
((un/marshall-unmarshall (let/ec k
(hash-table-get marshall-unmarshall p ((un/marshall-unmarshall
(lambda () (k marshalled)))) (hash-table-get marshall-unmarshall p
marshalled))] (lambda () (k marshalled))))
[boxed (box unmarshalled)]) marshalled))]
(hash-table-put! preferences p boxed) [boxed (box unmarshalled)])
boxed) (hash-table-put! preferences p boxed)
ans)))) boxed)]
[(box? ans) ans]
[else (error 'prefs.ss "robby error.1: ~a" ans)]))))
(define get-preference (mzlib:function:compose unbox get-preference-box)) (define get-preference (mzlib:function:compose unbox get-preference-box))
@ -76,18 +80,20 @@
(define save-user-preferences (define save-user-preferences
(let ([marshall-pref (let ([marshall-pref
(lambda (p boxed-value) (lambda (p ht-value)
(if (marshalled? boxed-value) (cond
(list p (marshalled-data boxed-value)) [(marshalled? ht-value) (list p (marshalled-data ht-value))]
(let* ([value (unbox boxed-value)] [(box? ht-value)
[marshalled (let* ([value (unbox ht-value)]
(let/ec k [marshalled
((un/marshall-marshall (let/ec k
(hash-table-get marshall-unmarshall p ((un/marshall-marshall
(lambda () (hash-table-get marshall-unmarshall p
(k value)))) (lambda ()
value))]) (k value))))
(list p marshalled))))]) value))])
(list p marshalled))]
[else (error 'prefs.ss "robby error.2: ~a" ht-value)]))])
(lambda () (lambda ()
(mred:debug:printf 'startup "saving user preferences") (mred:debug:printf 'startup "saving user preferences")
(call-with-output-file preferences-filename (call-with-output-file preferences-filename
@ -96,57 +102,63 @@
'replace) 'replace)
(mred:debug:printf 'startup "saved user preferences")))) (mred:debug:printf 'startup "saved user preferences"))))
(mred:exit:insert-exit-callback save-user-preferences)
(define read-user-preferences (define read-user-preferences
(let ([unmarshall-pref (let ([parse-pref
(lambda (input) (lambda (p marshalled)
(let ([p (mzlib:function:first input)] (let/ec k
[marshalled (mzlib:function:second input)]) (let* ([ht-pref (hash-table-get preferences p (lambda () 'not-in-table))]
(let/ec k [unmarshall-struct (hash-table-get marshall-unmarshall p (lambda () #f))])
(let* ([not-in-table (cond
(lambda () [(box? ht-pref)
(k (hash-table-put! preferences p (make-marshalled marshalled))))] (if unmarshall-struct
[ht-pref (hash-table-get preferences p not-in-table)] (set-box! ht-pref ((un/marshall-unmarshall unmarshall-struct) marshalled))
[unmarshall (hash-table-get marshall-unmarshall p (lambda () mzlib:function:identity))]) (set-box! ht-pref marshalled))]
(if (box? ht-pref) [(marshalled? ht-pref) (set-marshalled-data! ht-pref marshalled)]
(set-box! ht-pref (unmarshall marshalled)) [(eq? 'not-in-table ht-pref)
(set-marshalled-data! ht-pref marshalled))))))]) (if unmarshall-struct
(hash-table-put! preferences p (box ((un/marshall-unmarshall unmarshall-struct) marshalled)))
(hash-table-put! preferences p (make-marshalled marshalled)))]
[else (error 'prefs.ss "robby error.3: ~a" ht-pref)]))))])
(lambda () (lambda ()
(mred:debug:printf 'startup "reading user preferences") (mred:debug:printf 'startup "reading user preferences")
(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-pref input)))) (for-each (lambda (x) (apply parse-pref x)) input))))
(mred:debug:printf 'startup "read user preferences")))) (mred:debug:printf 'startup "read user preferences"))))
(define-struct ppanel (title container)) (define-struct ppanel (title container))
(define ppanels (define ppanels
(list (list
(make-ppanel "General" (make-ppanel "General"
(lambda (parent) (lambda (parent)
(let ([autosave-buffer (make-object mred:edit:edit%)]) (mred:vertical-panel parent #t #t
(mred:vertical-panel parent #t #t (list (horizontal-panel #t #f
(horizontal-panel #t #f (list (let ([c (check-box (lambda (_ command)
(check-box (lambda (_ command) (set-preference 'mred:highlight-parens (send command checked?)))
(set-preference 'mred:highlight-parens (send command checked?))) "Highlight Parens?")])
"Highlight Parens?") (send c set-value (get-preference 'mred:highlight-parens))
(panel #t #t)) c)
(horizontal-panel #t #f (panel #t #t)))
(check-box (lambda (_ command) (horizontal-panel
(set-preference 'mred:autosaving-on? (send command checked?))) #t #f
"Autosave?") (list (let ([c (check-box (lambda (_ command)
(panel #t #t)) (set-preference 'mred:autosaving-on? (send command checked?)))
(horizontal-panel #t #f "Autosave?")])
(message "Autosave timeout") (send c set-value (get-preference 'mred:autosaving-on?))
(let ([media (media-canvas)]) c)
(send media set-media autosave-buffer) (panel #t #t)))
media)))))) (horizontal-panel
(make-ppanel "Goodbye" #t #f
(lambda (parent) (list (let ([c (check-box (lambda (_ command)
(let* ([other-panel (make-object mred:vertical-panel% parent)] (set-preference 'mred:delete-forward? (not (send command checked?))))
[msg3 (make-object mred:message% other-panel "Goodbye")] "Remap delete to backspace?")])
[msg4 (make-object mred:message% other-panel "For Now")]) (send c set-value (not (get-preference 'mred:delete-forward?)))
(send other-panel change-children (lambda (l) (list msg3 msg4))) c)
other-panel))))) (panel #t #t)))))))))
(define make-run-once (define make-run-once
(lambda () (lambda ()
@ -162,7 +174,7 @@
(lambda (title container) (lambda (title container)
(run-once (run-once
(lambda () (lambda ()
(set! ppanels (cons (make-ppanel title container) ppanels)) (set! ppanels (append ppanels (list (make-ppanel title container))))
(when preferences-dialog (when preferences-dialog
(send preferences-dialog added-pane)))))) (send preferences-dialog added-pane))))))
@ -173,7 +185,7 @@
'() "Preferences")] '() "Preferences")]
[panel (make-object mred:vertical-panel% frame)] [panel (make-object mred:vertical-panel% frame)]
[top-panel (make-object mred:horizontal-panel% panel)] [top-panel (make-object mred:horizontal-panel% panel)]
[single-panel (make-object mred:single-panel% panel)] [single-panel (make-object mred:single-panel% panel -1 -1 -1 -1 wx:const-border)]
[panels (map (lambda (p) ((ppanel-container p) single-panel)) ppanels)] [panels (map (lambda (p) ((ppanel-container p) single-panel)) ppanels)]
[bottom-panel (make-object mred:horizontal-panel% panel)] [bottom-panel (make-object mred:horizontal-panel% panel)]
[popup-callback [popup-callback
@ -214,7 +226,8 @@
(send single-panel change-children (lambda (l) panels)) (send single-panel change-children (lambda (l) panels))
(send popup-menu set-selection 0) (send popup-menu set-selection 0)
(send single-panel active-child (car panels)) (send single-panel active-child (car panels))
(send frame show #t)))) (send frame show #t)
frame)))
(define run-once (make-run-once)) (define run-once (make-run-once))
@ -228,10 +241,12 @@
(define show-preferences-dialog (define show-preferences-dialog
(lambda () (lambda ()
(wx:bell) (mred:gui-utils:show-busy-cursor
'(run-once (lambda () (lambda ()
(if preferences-dialog (run-once
(send preferences-dialog show #t) (lambda ()
(set! preferences-dialog (make-preferences-dialog))))))) (if preferences-dialog
(send preferences-dialog show #t)
(set! preferences-dialog (make-preferences-dialog)))))))))
(read-user-preferences))) (read-user-preferences)))