From 7458906cd3cf79d3543a724f74a5dfa03f4c1992 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Mon, 11 Oct 2004 23:24:41 +0000 Subject: [PATCH] . original commit: f47c89e286bb105ef694c23f58a0d4dedaa62946 --- collects/framework/private/color.ss | 6 +----- collects/framework/private/editor.ss | 18 ++++++++++++++++++ collects/framework/private/main.ss | 4 +--- collects/framework/private/sig.ss | 5 ++++- collects/framework/private/text.ss | 20 +++++++++++++++----- 5 files changed, 39 insertions(+), 14 deletions(-) diff --git a/collects/framework/private/color.ss b/collects/framework/private/color.ss index 574bc512..ecdc15b3 100644 --- a/collects/framework/private/color.ss +++ b/collects/framework/private/color.ss @@ -46,9 +46,7 @@ backward-containing-sexp forward-match insert-close-paren - classify-position - - get-colorer-blank-style)) + classify-position)) (define text-mixin (mixin (text:basic<%>) (-text<%>) @@ -334,8 +332,6 @@ (set! token-sym->style #f) (set! get-token #f))) - (define/public (get-colorer-blank-style) (send (get-style-list) find-named-style "Standard")) - (define/public (is-frozen?) frozen?) ;; See docs diff --git a/collects/framework/private/editor.ss b/collects/framework/private/editor.ss index 87652a13..3bd458aa 100644 --- a/collects/framework/private/editor.ss +++ b/collects/framework/private/editor.ss @@ -293,6 +293,9 @@ (define standard-style-list (new style-list%)) (define (get-standard-style-list) standard-style-list) + (define default-color-style-name "framework:default-color") + (define (get-default-color-style-name) default-color-style-name) + (let ([delta (make-object style-delta% 'change-normal)]) (send delta set-delta 'change-family 'modern) (let ([style (send standard-style-list find-named-style "Standard")]) @@ -301,8 +304,23 @@ (send standard-style-list new-named-style "Standard" (send standard-style-list find-or-create-style (send standard-style-list find-named-style "Basic") + delta)))) + + (let ([style (send standard-style-list find-named-style default-color-style-name)]) + (if style + (send style set-delta delta) + (send standard-style-list new-named-style default-color-style-name + (send standard-style-list find-or-create-style + (send standard-style-list find-named-style "Standard") delta))))) + (define (set-default-font-color color) + (let* ([scheme-standard (send standard-style-list find-named-style default-color-style-name)] + [scheme-delta (make-object style-delta%)]) + (send scheme-standard get-delta scheme-delta) + (send scheme-delta set-delta-foreground color) + (send scheme-standard set-delta scheme-delta))) + (define (set-font-size size) (update-standard-style (lambda (scheme-delta) diff --git a/collects/framework/private/main.ss b/collects/framework/private/main.ss index 1c92975c..a2cf8090 100644 --- a/collects/framework/private/main.ss +++ b/collects/framework/private/main.ss @@ -251,9 +251,7 @@ (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))))) + (editor:set-default-font-color v))) ;; groups diff --git a/collects/framework/private/sig.ss b/collects/framework/private/sig.ss index 9b08e13e..e6d4a790 100644 --- a/collects/framework/private/sig.ss +++ b/collects/framework/private/sig.ss @@ -275,7 +275,8 @@ (get-standard-style-list set-standard-style-list-pref-callbacks set-standard-style-list-delta - update-standard-style)) + set-default-font-color + get-default-color-style-name)) (define-signature framework:editor^ ((open framework:editor-class^) (open framework:editor-fun^))) @@ -295,6 +296,7 @@ (define-signature framework:text-class^ (basic<%> + foreground-color<%> hide-caret/selection<%> nbsp->space<%> delegate<%> @@ -322,6 +324,7 @@ info% basic-mixin + foreground-color-mixin hide-caret/selection-mixin nbsp->space-mixin delegate-mixin diff --git a/collects/framework/private/text.ss b/collects/framework/private/text.ss index bf338638..2cde3dac 100644 --- a/collects/framework/private/text.ss +++ b/collects/framework/private/text.ss @@ -53,6 +53,7 @@ WARNING: printf is rebound in the body of the unit to always highlight-range get-highlighted-ranges get-styles-fixed + get-fixed-style set-styles-fixed move/copy-to-edit initial-autowrap-bitmap)) @@ -74,6 +75,8 @@ WARNING: printf is rebound in the body of the unit to always (define ranges null) (define/public-final (get-highlighted-ranges) ranges) + (define/public (get-fixed-style) + (send (get-style-list) find-named-style "Standard")) (define (invalidate-rectangles rectangles) (let ([b1 (box 0)] @@ -328,10 +331,7 @@ WARNING: printf is rebound in the body of the unit to always (begin-edit-sequence)) (define/augment (after-insert start len) (when styles-fixed? - (change-style (send (get-style-list) find-named-style "Standard") - start - (+ start len) - #f)) + (change-style (get-fixed-style) start (+ start len) #f)) (end-edit-sequence) (inner (void) after-insert start len)) @@ -361,12 +361,22 @@ WARNING: printf is rebound in the body of the unit to always (super-instantiate ()) (set-autowrap-bitmap (initial-autowrap-bitmap)))) + (define foreground-color<%> + (interface (basic<%> editor:standard-style-list<%>) + )) + + (define foreground-color-mixin + (mixin (basic<%> editor:standard-style-list<%>) (foreground-color<%>) + (inherit begin-edit-sequence end-edit-sequence change-style) + (define/override (get-fixed-style) + (send (editor:get-standard-style-list) find-named-style (editor:get-default-color-style-name))) + (super-new))) + (define hide-caret/selection<%> (interface (basic<%>))) (define hide-caret/selection-mixin (mixin (basic<%>) (hide-caret/selection<%>) (inherit get-start-position get-end-position hide-caret) (define/augment (after-set-position) - ;; >>> super was not here <<< (hide-caret (= (get-start-position) (get-end-position))) (inner (void) after-set-position)) (super-instantiate ())))