diff --git a/collects/framework/framework.ss b/collects/framework/framework.ss index af95dda1..611c413e 100644 --- a/collects/framework/framework.ss +++ b/collects/framework/framework.ss @@ -1327,6 +1327,13 @@ "@flink editor:get-standard-style-list %" ".") + (editor:update-standard-style + (-> (-> (is-a?/c style-delta%) void?) void?) + (change-delta) + "Calls \\var{change-delta} with the \"Standard\" style delta from" + "the result of" + "@flink editor:get-standard-style-list %" + ".") (editor:set-standard-style-list-delta (string? (is-a?/c style-delta%) . -> . void?) (name delta) diff --git a/collects/framework/private/color-prefs.ss b/collects/framework/private/color-prefs.ss index 0923cc99..72b48dbd 100644 --- a/collects/framework/private/color-prefs.ss +++ b/collects/framework/private/color-prefs.ss @@ -24,90 +24,98 @@ ;; build-color-selection-panel : (is-a?/c area-container<%>) symbol string string -> void ;; constructs a panel containg controls to configure the preferences panel. ;; BUG: style changes don't update the check boxes. - (define (build-color-selection-panel parent pref-sym style-name example-text) - (define hp (new horizontal-panel% - (parent parent) - (style '(border)) - (stretchable-height #f))) - (define e (new (class standard-style-list-text% - (inherit change-style get-style-list) - (define/augment (after-insert pos offset) - (inner (void) after-insert pos offset) - (let ([style (send (get-style-list) - find-named-style - style-name)]) - (change-style style pos (+ pos offset) #f))) - (super-new)))) - (define c (new canvas:color% - (parent hp) - (editor e) - (style '(hide-hscroll - hide-vscroll)))) - - (define delta (preferences:get pref-sym)) - (define (make-check name on off) - (let* ([c (lambda (check command) - (if (send check get-value) - (on) - (off)) - (preferences:set pref-sym delta))] - [check (make-object check-box% name hp c)]) - check)) - - (define slant-check - (make-check (string-constant cs-italic) - (lambda () - (send delta set-style-on 'slant) - (send delta set-style-off 'base)) - (lambda () - (send delta set-style-on 'base) - (send delta set-style-off 'slant)))) - (define bold-check - (make-check (string-constant cs-bold) - (lambda () - (send delta set-weight-on 'bold) - (send delta set-weight-off 'base)) - (lambda () - (send delta set-weight-on 'base) - (send delta set-weight-off 'bold)))) - (define underline-check - (make-check (string-constant cs-underline) - (lambda () - (send delta set-underlined-on #t) - (send delta set-underlined-off #f)) - (lambda () - (send delta set-underlined-off #t) - (send delta set-underlined-on #f)))) - (define color-button - (and (>= (get-display-depth) 8) - (make-object button% - (string-constant cs-change-color) - hp - (lambda (color-button evt) - (let* ([add (send delta get-foreground-add)] - [color (make-object color% - (send add get-r) - (send add get-g) - (send add get-b))] - [users-choice - (get-color-from-user - (format sc-choose-color example-text) - (send color-button get-top-level-window) - color)]) - (when users-choice - (send delta set-delta-foreground users-choice) - (preferences:set pref-sym delta))))))) - (define style (send (send e get-style-list) find-named-style style-name)) - - (send c set-line-count 1) - (send c allow-tab-exit #t) - - (send e insert example-text) - (send e set-position 0) - - (send slant-check set-value (eq? (send style get-style) 'slant)) - (send bold-check set-value (eq? (send style get-weight) 'bold)) - (send underline-check set-value (send style get-underlined))) + (define build-color-selection-panel + (opt-lambda (parent + pref-sym + style-name + example-text + [update-style-delta + (lambda (func) + (let ([delta (preferences:get pref-sym)]) + (func delta) + (preferences:set pref-sym delta)))]) + (define hp (new horizontal-panel% + (parent parent) + (style '(border)) + (stretchable-height #f))) + (define e (new (class standard-style-list-text% + (inherit change-style get-style-list) + (define/augment (after-insert pos offset) + (inner (void) after-insert pos offset) + (let ([style (send (get-style-list) + find-named-style + style-name)]) + (change-style style pos (+ pos offset) #f))) + (super-new)))) + (define c (new canvas:color% + (parent hp) + (editor e) + (style '(hide-hscroll + hide-vscroll)))) + + (define (make-check name on off) + (let* ([c (lambda (check command) + (if (send check get-value) + (update-style-delta on) + (update-style-delta off)))] + [check (make-object check-box% name hp c)]) + check)) + + (define slant-check + (make-check (string-constant cs-italic) + (lambda (delta) + (send delta set-style-on 'slant) + (send delta set-style-off 'base)) + (lambda (delta) + (send delta set-style-on 'base) + (send delta set-style-off 'slant)))) + (define bold-check + (make-check (string-constant cs-bold) + (lambda (delta) + (send delta set-weight-on 'bold) + (send delta set-weight-off 'base)) + (lambda (delta) + (send delta set-weight-on 'base) + (send delta set-weight-off 'bold)))) + (define underline-check + (make-check (string-constant cs-underline) + (lambda (delta) + (send delta set-underlined-on #t) + (send delta set-underlined-off #f)) + (lambda (delta) + (send delta set-underlined-off #t) + (send delta set-underlined-on #f)))) + (define color-button + (and (>= (get-display-depth) 8) + (make-object button% + (string-constant cs-change-color) + hp + (lambda (color-button evt) + (let* ([add (send (preferences:get pref-sym) get-foreground-add)] + [color (make-object color% + (send add get-r) + (send add get-g) + (send add get-b))] + [users-choice + (get-color-from-user + (format sc-choose-color example-text) + (send color-button get-top-level-window) + color)]) + (when users-choice + (update-style-delta + (lambda (delta) + (send delta set-delta-foreground users-choice))))))))) + (define style (send (send e get-style-list) find-named-style style-name)) + + (send c set-line-count 1) + (send c allow-tab-exit #t) + + (send e insert example-text) + (send e set-position 0) + + (send slant-check set-value (eq? (send style get-style) 'slant)) + (send bold-check set-value (eq? (send style get-weight) 'bold)) + (send underline-check set-value (send style get-underlined)))) (define (add/mult-set m v) (send m set (car v) (cadr v) (caddr v))) @@ -194,16 +202,60 @@ (list (string-constant preferences-colors) (string-constant background-color)) (lambda (parent) - (add-solid-color-config (string-constant background-color) - parent - 'framework:basic-canvas-background) - (build-color-selection-panel parent - 'framework:default-text-color - "Basic" - (string-constant default-text-color))))) + (let ([vp (new vertical-panel% (parent parent))]) + (add-solid-color-config (string-constant background-color) + vp + 'framework:basic-canvas-background) + (add-solid-color-config (string-constant paren-match-color) + vp + 'framework:paren-match-color) + (build-text-foreground-selection-panel vp + 'framework:default-text-color + "Standard" + (string-constant default-text-color)))))) + + (define (build-text-foreground-selection-panel parent pref-sym style-name example-text) + (define hp (new horizontal-panel% + (parent parent) + (style '(border)) + (stretchable-height #f))) + (define e (new (class standard-style-list-text% + (inherit change-style get-style-list) + (define/augment (after-insert pos offset) + (inner (void) after-insert pos offset) + (let ([style (send (get-style-list) + find-named-style + style-name)]) + (change-style style pos (+ pos offset) #f))) + (super-new)))) + (define c (new canvas:color% + (parent hp) + (editor e) + (style '(hide-hscroll + hide-vscroll)))) + (define color-button + (and (>= (get-display-depth) 8) + (make-object button% + (string-constant cs-change-color) + hp + (lambda (color-button evt) + (let ([users-choice + (get-color-from-user + (format sc-choose-color example-text) + (send color-button get-top-level-window) + (preferences:get pref-sym))]) + (when users-choice + (preferences:set pref-sym users-choice))))))) + (define style (send (send e get-style-list) find-named-style style-name)) + + (send c set-line-count 1) + (send c allow-tab-exit #t) + + (send e insert example-text) + (send e set-position 0)) (define (add-solid-color-config label parent pref-id) - (letrec ([panel (new vertical-panel% (parent parent))] + (letrec ([panel (new vertical-panel% (parent parent) (stretchable-height #f))] [hp (new horizontal-panel% (parent panel) (stretchable-height #f))] [msg (new message% (parent hp) (label label))] [canvas diff --git a/collects/framework/private/main.ss b/collects/framework/private/main.ss index 5d728f85..1c92975c 100644 --- a/collects/framework/private/main.ss +++ b/collects/framework/private/main.ss @@ -241,9 +241,19 @@ (scheme:get-color-prefs-table)) (preferences:set-default 'framework:coloring-active #t boolean?) - (color-prefs:register-color-pref 'framework:default-text-color - "Basic" - (send the-color-database find-color "black")) + (preferences:set-default 'framework:default-text-color + (send the-color-database find-color "Black") + (lambda (x) (is-a? x color%))) + + (preferences:set-un/marshall 'framework:default-text-color + (lambda (c) (list (send c red) (send c green) (send c blue))) + (lambda (lst) + (make-object color% (car lst) (cadr lst) (caddr lst)))) + (preferences:add-callback 'framework:default-text-color + (lambda (p v) + (editor:update-standard-style + (lambda (style-delta) + (send style-delta set-delta-foreground v))))) ;; groups diff --git a/collects/framework/private/preferences.ss b/collects/framework/private/preferences.ss index 8d466f32..ea6c8dc2 100644 --- a/collects/framework/private/preferences.ss +++ b/collects/framework/private/preferences.ss @@ -604,53 +604,9 @@ 'framework:paren-match (string-constant flash-paren-match) values values) - (scheme-panel-procs scheme-panel) - (make-highlight-color-choice scheme-panel))))]) + (scheme-panel-procs scheme-panel))))]) (add-scheme-checkbox-panel))) - (define (make-highlight-color-choice panel) - (let* ([hp (instantiate horizontal-panel% () - (parent panel) - (stretchable-height #f))] - [msg (make-object message% (string-constant paren-match-color) hp)] - [scheme-higlight-canvas (make-object scheme-highlight-canvas% hp)] - [button (make-object button% - (string-constant choose-color) - hp - (lambda (x y) (change-highlight-color panel)))]) - (void))) - - (define scheme-highlight-canvas% - (class canvas% - (inherit get-client-size get-dc) - (define/override (on-paint) - (do-draw (get 'framework:paren-match-color))) - (define/public (do-draw color) - (let ([dc (get-dc)]) - (send dc set-pen (send the-pen-list find-or-create-pen - color - 1 - 'solid)) - (send dc set-brush (send the-brush-list find-or-create-brush - color - 'solid)) - (let-values ([(w h) (get-client-size)]) - (send dc draw-rectangle 0 0 w h)))) - (super-instantiate ()) - (inherit stretchable-width min-width) - (add-callback - 'framework:paren-match-color - (lambda (p v) - (do-draw v))))) - - (define (change-highlight-color parent) - (let ([new-color - (get-color-from-user (string-constant choose-paren-highlight-color) - (send parent get-top-level-window) - (get 'framework:paren-match-color))]) - (when new-color - (set 'framework:paren-match-color new-color)))) - (define (add-editor-checkbox-panel) (letrec ([add-editor-checkbox-panel (lambda () diff --git a/collects/framework/private/scheme.ss b/collects/framework/private/scheme.ss index 1f333c24..97e5b093 100644 --- a/collects/framework/private/scheme.ss +++ b/collects/framework/private/scheme.ss @@ -42,7 +42,6 @@ [-text<%> text<%>] [-text% text%]) - (define text-balanced? (opt-lambda (text [start 0] [in-end #f]) (let* ([end (or in-end (send text last-position))] @@ -345,9 +344,6 @@ (define (get-wordbreak-map) wordbreak-map) (init-wordbreak-map wordbreak-map) - (define (get-match-color) (preferences:get 'framework:paren-match-color)) - (define mismatch-color (make-object color% "PINK")) - (define matching-parenthesis-style (let ([matching-parenthesis-delta (make-object style-delta% 'change-bold)] [style-list (editor:get-standard-style-list)]) diff --git a/collects/framework/private/sig.ss b/collects/framework/private/sig.ss index 59664afd..9b08e13e 100644 --- a/collects/framework/private/sig.ss +++ b/collects/framework/private/sig.ss @@ -274,7 +274,8 @@ (define-signature framework:editor-fun^ (get-standard-style-list set-standard-style-list-pref-callbacks - set-standard-style-list-delta)) + set-standard-style-list-delta + update-standard-style)) (define-signature framework:editor^ ((open framework:editor-class^) (open framework:editor-fun^))) @@ -510,7 +511,9 @@ (register-color-pref add-to-preferences-panel build-color-selection-panel - add-background-preferences-panel)) + add-background-preferences-panel + marshall-style + unmarshall-style)) (define-signature framework:color-prefs^ ((open framework:color-prefs-class^) (open framework:color-prefs-fun^)))