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

..

Browse Source 
original commit: ea67df43bc9396a472530ee965b679c9c598bc1e
This commit is contained in:
Robby Findler 2002-10-10 18:33:19 +00:00
parent 85561947ca
commit ba1cf81e84
2 changed files with 51 additions and 26 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
collects/framework/framework.ss
View File

@ -185,8 +185,16 @@
"default preferences.") "default preferences.")
(preferences:add-panel (preferences:add-panel
(string? ((union string? (cons/p string? (listof string?)))
((is-a?/c area-container-window<%>) . -> . (is-a?/c area-container-window<%>)) ((is-a?/c area-container-window<%>)
. ->d .
(lambda (parent)
(let ([children (map (lambda (x) x) (send parent get-children))])
(lambda (child)
(and (is-a? child area-container-window<%>)
(andmap eq?
(cons child children)
(send parent get-children)))))))
. -> . . -> .
void?) void?)
(name f) (name f)

63
collects/framework/private/preferences.ss
View File

@ -328,8 +328,14 @@
;;; ;;;
(define-struct ppanel (title container panel)) ;; ppanel-tree =
;; (union (make-ppanel-leaf string (union #f panel) (panel -> panel))
;; (make-ppanel-interior string (union #f panel) (listof panel-tree)))
(define-struct ppanel (name panel))
(define-struct (ppanel-leaf ppanel) (maker))
(define-struct (ppanel-interior ppanel) (children))
;; ppanels : (listof ppanel-tree)
(define ppanels null) (define ppanels null)
(define (add-to-scheme-checkbox-panel f) (define (add-to-scheme-checkbox-panel f)
@ -656,18 +662,39 @@
(define preferences-dialog #f) (define preferences-dialog #f)
(define add-panel (define (add-panel title make-panel)
(lambda (title container) (let ([titles (if (string? title)
(unless (and (string? title) (list title)
(procedure? container) title)])
(procedure-arity-includes? container 1)) (add-to-existing-tree
(error 'preferences:add-panel titles
"expected a string and a function that can accept one argument, got ~e and ~e" make-panel
title container)) (lambda (new-subtree) (set! ppanels new-subtree)))))
(set! ppanels
(append ppanels (list (make-ppanel title container #f)))) (define (add-to-existing-children titles make-panel banger)
(let loop ([children ppanels]
[title (car titles)]
[titles (cdr titles)]
[banger banger])
(cond
[(null? children)
(banger (build-new-subtree titles make-panel))]
[else
(let ([child (car children)])
(if (string=? (ppanel-name child) title)
(add-to-existing-children
(build-new-subtree
(append ppanels
(list (make-ppanel (if (string? title)
(list title)
title)
container
#f))))
(when preferences-dialog (when preferences-dialog
(send preferences-dialog added-pane title)))) (error 'add-panel "preferences dialog already open, cannot add new panels")))
(define (hide-dialog) (define (hide-dialog)
(when preferences-dialog (when preferences-dialog
@ -696,12 +723,7 @@
(lambda () (lambda ()
(letrec ([stashed-prefs (get-preference main-preferences-symbol (lambda () null))] (letrec ([stashed-prefs (get-preference main-preferences-symbol (lambda () null))]
[frame [frame
(make-object (class frame:basic% (make-object frame:basic%
(define/public (added-pane title)
(lambda (title)
(ensure-constructed)
(send tap-panel append title)))
(super-instantiate ()))
(string-constant preferences))] (string-constant preferences))]
[panel (make-object vertical-panel% (send frame get-area-container))] [panel (make-object vertical-panel% (send frame get-area-container))]
[popup-callback [popup-callback
@ -723,11 +745,6 @@
(for-each (lambda (ppanel) (for-each (lambda (ppanel)
(unless (ppanel-panel ppanel) (unless (ppanel-panel ppanel)
(let ([panel ((ppanel-container ppanel) single-panel)]) (let ([panel ((ppanel-container ppanel) single-panel)])
(unless (and (object? panel)
(is-a? panel area-container<%>))
(error 'preferences-dialog
"expected the result of the function passed to preferences:add-panel to implement the area-container% interface. Got ~a~n"
panel))
(set-ppanel-panel! ppanel panel)))) (set-ppanel-panel! ppanel panel))))
ppanels) ppanels)
(send single-panel change-children (lambda (l) (map ppanel-panel ppanels))) (send single-panel change-children (lambda (l) (map ppanel-panel ppanels)))