From 2431e3f435391b37d8ba65c4ddea77d9babbbd7b Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Thu, 10 Oct 2002 22:53:21 +0000 Subject: [PATCH] .. original commit: 64bfdcf06628e9fcf649c6083c66f1e00a801d0c --- collects/framework/framework.ss | 20 +- collects/framework/private/preferences.ss | 284 +++++++++++++--------- collects/framework/private/scheme.ss | 3 +- 3 files changed, 181 insertions(+), 126 deletions(-) diff --git a/collects/framework/framework.ss b/collects/framework/framework.ss index cf8a74b0..d5980f17 100644 --- a/collects/framework/framework.ss +++ b/collects/framework/framework.ss @@ -3,6 +3,7 @@ (require (lib "unitsig.ss") (lib "mred.ss" "mred") (lib "mred-sig.ss" "mred") + (lib "class.ss") "test.ss" "gui-utils.ss" @@ -193,14 +194,25 @@ (lambda (child) (and (is-a? child area-container-window<%>) (andmap eq? - (cons child children) + (append children (list child)) (send parent get-children))))))) . -> . void?) - (name f) + (labels f) "\\rawscm{preferences:add-preference-panel} adds the result of" - "\\var{f} with name \\var{name} to the preferences dialog" - "box. When the preference dialog is opened for the first" + "\\var{f} with name \\var{labels} to the preferences dialog" + "box." + "" + "The labels determine where this preference panel is placed" + "in the dialog. If the list is just one string, the" + "preferences panel is placed at the top level of the dialog." + "If there are more strings, a hierarchy of nested panels is" + "created and the new panel is added at the end." + "If multiple calls to \\rawscm{preferences:add-preference-panel}" + "pass the same prefix of strings, those panels are placed in the" + "same children." + "" + "When the preference dialog is opened for the first" "time, the function \\var{f} is called with a panel, and" "\\var{f} is expected to add a new child panel to it and add" "whatever preferences configuration controls it wants to that" diff --git a/collects/framework/private/preferences.ss b/collects/framework/private/preferences.ss index dedf9ba3..8b284ab4 100644 --- a/collects/framework/private/preferences.ss +++ b/collects/framework/private/preferences.ss @@ -338,6 +338,162 @@ ;; ppanels : (listof ppanel-tree) (define ppanels null) + (define preferences-dialog #f) + + (define (add-panel title make-panel) + (when preferences-dialog + (error 'add-panel "preferences dialog already open, cannot add new panels")) + (let ([titles (if (string? title) + (list title) + title)]) + (add-to-existing-children + titles + make-panel + (lambda (new-subtree) (set! ppanels (cons new-subtree ppanels)))))) + + ;; add-to-existing-children : (listof string) (panel -> panel) (ppanel -> void) + ;; adds the child specified by the path in-titles to the tree. + (define (add-to-existing-children in-titles make-panel banger) + (let loop ([children ppanels] + [title (car in-titles)] + [titles (cdr in-titles)] + [banger banger]) + (cond + [(null? children) + (banger (build-new-subtree (cons title titles) make-panel))] + [else + (let ([child (car children)]) + (if (string=? (ppanel-name child) title) + (cond + [(null? titles) + (error 'add-child "child already exists with this path: ~e" in-titles)] + [(ppanel-leaf? child) + (error 'add-child "new child's path conflicts with existing path: ~e" in-titles)] + [else + (loop + (ppanel-interior-children child) + (car titles) + (cdr titles) + (lambda (x) + (set-ppanel-interior-children! + (cons + x + (ppanel-interior-children child)))))]) + (loop + (cdr children) + title + titles + (lambda (x) + (set-cdr! children + (cons x (cdr children)))))))]))) + + ;; build-new-subtree : (cons string (listof string)) (panel -> panel) -> ppanel + (define (build-new-subtree titles make-panel) + (let loop ([title (car titles)] + [titles (cdr titles)]) + (cond + [(null? titles) (make-ppanel-leaf title #f make-panel)] + [else + (make-ppanel-interior + title + #f + (list (loop (car titles) (cdr titles))))]))) + + + (define (hide-dialog) + (when preferences-dialog + (send preferences-dialog show #f))) + + (define (show-dialog) + (save) + (if preferences-dialog + (send preferences-dialog show #t) + (set! preferences-dialog + (make-preferences-dialog)))) + + (define (add-can-close-dialog-callback cb) + (set! can-close-dialog-callbacks + (cons cb can-close-dialog-callbacks))) + + (define (add-on-close-dialog-callback cb) + (set! on-close-dialog-callbacks + (cons cb on-close-dialog-callbacks))) + + (define on-close-dialog-callbacks null) + + (define can-close-dialog-callbacks null) + + (define (make-preferences-dialog) + (letrec ([stashed-prefs (get-preference main-preferences-symbol (lambda () null))] + [frame + (make-object frame:basic% + (string-constant preferences))] + [build-ppanel-tree + (lambda (ppanel tab-panel single-panel) + (send tab-panel append (ppanel-name ppanel)) + (cond + [(ppanel-leaf? ppanel) + ((ppanel-leaf-maker ppanel) single-panel)] + [(ppanel-interior? ppanel) + (let-values ([(tab-panel single-panel) (make-tab/single-panel single-panel #t)]) + (for-each + (lambda (ppanel) (build-ppanel-tree ppanel tab-panel single-panel)) + (ppanel-interior-children ppanel)))]))] + [make-tab/single-panel + (lambda (parent inset?) + (letrec ([spacer (and inset? + (instantiate vertical-panel% () + (parent parent) + (border 10)))] + [tab-panel (instantiate tab-panel% () + (choices null) + (parent (if inset? spacer parent)) + (callback (lambda (_1 _2) + (tab-panel-callback + single-panel + tab-panel))))] + [single-panel (instantiate panel:single% () + (parent tab-panel))]) + (values tab-panel single-panel)))] + [tab-panel-callback + (lambda (single-panel tab-panel) + (send single-panel active-child + (list-ref (send single-panel get-children) + (send tab-panel get-selection))))] + [panel (make-object vertical-panel% (send frame get-area-container))] + [_ (let-values ([(tab-panel single-panel) (make-tab/single-panel panel #f)]) + (for-each + (lambda (ppanel) + (build-ppanel-tree ppanel tab-panel single-panel)) + ppanels) + (let ([single-panel-children (send single-panel get-children)]) + (unless (null? single-panel-children) + (send single-panel active-child (car single-panel-children)) + (send tab-panel set-selection 0))) + (send tab-panel focus))] + [bottom-panel (make-object horizontal-panel% panel)] + [ok-callback (lambda args + (when (andmap (lambda (f) (f)) + can-close-dialog-callbacks) + (for-each + (lambda (f) (f)) + on-close-dialog-callbacks) + (save) + (hide-dialog)))] + [cancel-callback (lambda (_1 _2) + (hide-dialog) + (install-stashed-preferences stashed-prefs))]) + (gui-utils:ok/cancel-buttons + bottom-panel + ok-callback + cancel-callback) + (make-object grow-box-spacer-pane% bottom-panel) + (send* bottom-panel + (stretchable-height #f) + (set-alignment 'right 'center)) + (send frame show #t) + frame)) + (define (add-to-scheme-checkbox-panel f) (set! scheme-panel-procs (let ([old scheme-panel-procs]) @@ -400,7 +556,9 @@ (lambda () (set! add-scheme-checkbox-panel void) (add-checkbox-panel - (string-constant scheme-prefs-panel-label) + (list + (string-constant editor-prefs-panel-label) + (string-constant scheme-prefs-panel-label)) (lambda (scheme-panel) (make-check scheme-panel 'framework:highlight-parens @@ -422,7 +580,8 @@ (lambda () (set! add-editor-checkbox-panel void) (add-checkbox-panel - (string-constant editor-prefs-panel-label) + (list (string-constant editor-prefs-panel-label) + (string-constant general-prefs-panel-label)) (lambda (editor-panel) (make-recent-items-slider editor-panel) (make-check editor-panel @@ -469,7 +628,7 @@ (letrec ([add-warnings-checkbox-panel (lambda () (set! add-warnings-checkbox-panel void) - (add-checkbox-panel + (add-checkbox-panel (string-constant warnings-prefs-panel-label) (lambda (warnings-panel) (make-check warnings-panel @@ -658,121 +817,4 @@ main)))) (set! local-add-font-panel void)) - (define (add-font-panel) (local-add-font-panel)) - - (define preferences-dialog #f) - - (define (add-panel title make-panel) - (let ([titles (if (string? title) - (list title) - title)]) - (add-to-existing-tree - titles - make-panel - (lambda (new-subtree) (set! ppanels new-subtree))))) - - (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 - (error 'add-panel "preferences dialog already open, cannot add new panels"))) - - (define (hide-dialog) - (when preferences-dialog - (send preferences-dialog show #f))) - - (define (show-dialog) - (save) - (if preferences-dialog - (send preferences-dialog show #t) - (set! preferences-dialog - (make-preferences-dialog)))) - - (define (add-can-close-dialog-callback cb) - (set! can-close-dialog-callbacks - (cons cb can-close-dialog-callbacks))) - - (define (add-on-close-dialog-callback cb) - (set! on-close-dialog-callbacks - (cons cb on-close-dialog-callbacks))) - - (define on-close-dialog-callbacks null) - - (define can-close-dialog-callbacks null) - - (define make-preferences-dialog - (lambda () - (letrec ([stashed-prefs (get-preference main-preferences-symbol (lambda () null))] - [frame - (make-object frame:basic% - (string-constant preferences))] - [panel (make-object vertical-panel% (send frame get-area-container))] - [popup-callback - (lambda (tab-panel evt) - (unless (null? ppanels) - (send single-panel active-child - (ppanel-panel - (list-ref ppanels - (send tab-panel get-selection))))))] - [tap-panel - (instantiate tab-panel% () - (choices (map ppanel-title ppanels)) - (parent panel) - (callback popup-callback))] - [single-panel (make-object panel:single% tap-panel)] - [bottom-panel (make-object horizontal-panel% panel)] - [ensure-constructed - (lambda () - (for-each (lambda (ppanel) - (unless (ppanel-panel ppanel) - (let ([panel ((ppanel-container ppanel) single-panel)]) - (set-ppanel-panel! ppanel panel)))) - ppanels) - (send single-panel change-children (lambda (l) (map ppanel-panel ppanels))) - (unless (null? ppanels) - (send single-panel active-child (ppanel-panel (car ppanels)))))] - - [ok-callback (lambda args - (when (andmap (lambda (f) (f)) - can-close-dialog-callbacks) - (for-each - (lambda (f) (f)) - on-close-dialog-callbacks) - (save) - (hide-dialog)))] - [cancel-callback (lambda (_1 _2) - (hide-dialog) - (install-stashed-preferences stashed-prefs))]) - (gui-utils:ok/cancel-buttons - bottom-panel - ok-callback - cancel-callback) - (make-object grow-box-spacer-pane% bottom-panel) - (send* bottom-panel - (stretchable-height #f) - (set-alignment 'right 'center)) - (ensure-constructed) - (unless (null? ppanels) - (send tap-panel set-selection 0)) - (send tap-panel focus) - (send frame show #t) - frame)))))) + (define (add-font-panel) (local-add-font-panel))))) diff --git a/collects/framework/private/scheme.ss b/collects/framework/private/scheme.ss index bf808ebd..e3885038 100644 --- a/collects/framework/private/scheme.ss +++ b/collects/framework/private/scheme.ss @@ -1321,7 +1321,8 @@ (define (add-preferences-panel) (preferences:add-panel - (string-constant indenting-prefs-panel-label) + (list (string-constant editor-prefs-panel-label) + (string-constant indenting-prefs-panel-label)) (lambda (p) (let*-values ([(get-keywords)