From 332837e92819f2d3ac423914b4036a51512eecb1 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Tue, 9 Dec 2003 23:01:57 +0000 Subject: [PATCH] .. original commit: 898804df64c0279bdccb43bf3647a0f935de5c90 --- collects/framework/framework.ss | 84 +++++++++++------- collects/framework/private/color-prefs.ss | 103 ++++------------------ collects/framework/private/color.ss | 12 +-- collects/framework/private/editor.ss | 5 +- collects/framework/private/main.ss | 14 ++- collects/framework/private/scheme.ss | 63 ++++++------- collects/framework/private/sig.ss | 14 +-- 7 files changed, 125 insertions(+), 170 deletions(-) diff --git a/collects/framework/framework.ss b/collects/framework/framework.ss index 879b41a1..f48369d9 100644 --- a/collects/framework/framework.ss +++ b/collects/framework/framework.ss @@ -1310,6 +1310,38 @@ "Installs the ``Scheme'' preferences panel in the ``Syntax Coloring''" "section.") + (scheme:get-color-prefs-table + (-> (listof (list/p symbol? (is-a?/c color%)))) + () + "Returns a table mapping from symbols (naming the categories that" + "the online colorer uses for Scheme mode coloring) to their" + "colors." + "" + "These symbols are suitable for input to" + "@flink scheme:short-sym->pref-name" + "and" + "@flink scheme:short-sym->style-name %" + ".") + + (scheme:short-sym->pref-name + (symbol? . -> . symbol?) + (short-sym) + "Builds the symbol naming the preference from one of the symbols" + "in the table returned by" + "@flink scheme:get-color-prefs-table %" + ".") + + (scheme:short-sym->style-name + (symbol? . -> . string?) + (short-sym) + "Builds the symbol naming the editor style from one of the symbols" + "in the table returned by" + "@flink scheme:get-color-prefs-table %" + ". This style is a named style in the style list" + "returned by" + "@flink editor:get-standard-style-list %" + ".") + (editor:set-standard-style-list-delta (string? (is-a?/c style-delta%) . -> . void?) (name delta) @@ -1516,7 +1548,25 @@ (xyz) "Extracts the z component of \\var{xyz}.") - + (color-prefs:register-color-pref + (symbol? string? (is-a?/c color%) . -> . void?) + (pref-name style-name color) + "This function registers a color preference and initializes the" + "style list returned from" + "@flink editor:get-standard-style-list %" + ". In particular, it calls " + "@flink preferences:set-default " + "and " + "@flink preferences:set-un/marshall " + "to install the pref for \\var{pref-name}, using" + "\\var{color} as the default color. The preference" + "is bound to a \\iscmclass{style-delta}, and initially the \\iscmclass{style-delta}" + "changes the foreground color to \\var{color}." + "Then, it calls " + "@flink editor:set-standard-style-list-delta" + "passing the \\var{style-name} and the newly" + "created \\iscmclass{style-delta}.") + (color-prefs:add-preferences-panel (-> void?) () @@ -1532,34 +1582,4 @@ (parent pref-sym style-name example-text) "...") - (color-prefs:make-style-delta - ((union string? (is-a?/c color%)) any? any? any? . -> . (is-a?/c style-delta%)) - (color bold? underline? italic?) - "Soon to be deprecated.") - (color-prefs:add-staged - (string? (listof (list/p symbol? (is-a?/c style-delta%))) . -> . (-> any)) - (tab-name styles/defaults) - "Sets up the preferences defaults for \\var{tab-name} and returns a" - "function that will install a panel named \\var{tab-name} in the" - "``Syntax Coloring'' section of the preferences dialog." - "" - "\\rawscm{color:prefs-add-staged} can be invoked many times to incrementally add" - "styles to a particular tab. However, \\rawscm{color:prefs-add-staged} cannot be" - "called after the preferences window is created. Repeated calls to funtions returned" - "by \\rawscm{color:prefs-add-staged} for a particular \\var{tab-name} have no effect" - "after the first call.") - (color-prefs:add - (string? (listof (list/p symbol? (is-a?/c style-delta%))) . -> . any) - (tab-name styles/defaults) - "Same as \\rawscm{color-prefs:add-staged}, except that it immediately" - "calls the function for installing the preferences panel.") - (color-prefs:get-full-pref-name - (string? printable? . -> . symbol?) - (tab-name preference-name) - "Returns the name of the preference that color-prefs uses for preference" - "\\var{preference-name} in \\var{tab-name}.") - (color-prefs:get-full-style-name - (string? printable? . -> . string?) - (tab-name preference-name) - "Returns the name of the style that color-prefs uses for preference" - "\\var{preference-name} in \\var{tab-name}."))) + )) diff --git a/collects/framework/private/color-prefs.ss b/collects/framework/private/color-prefs.ss index 496e7829..1ffee22f 100644 --- a/collects/framework/private/color-prefs.ss +++ b/collects/framework/private/color-prefs.ss @@ -19,28 +19,15 @@ [panel : framework:panel^]) (define standard-style-list-text% (editor:standard-style-list-mixin text%)) - - (define (build-many-color-selection-panels symbols tab-name parent) - (let ([vp (new vertical-panel% (parent parent))]) - (for-each - (lambda (symbol) - (build-color-selection-panel - vp - (get-full-pref-name tab-name symbol) - (get-full-style-name tab-name symbol) - (symbol->string symbol))) - symbols))) ;; 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)))) - (define delta (preferences:get pref-sym)) - (define c (make-object editor-canvas% hp - #f - (list 'hide-hscroll - 'hide-vscroll))) + (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) (rename [super-after-insert after-insert]) @@ -52,7 +39,13 @@ style-name)]) (change-style style pos (+ pos offset) #f))) (super-instantiate ())))) + (define c (new editor-canvas% + (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) @@ -116,7 +109,6 @@ #t)) (editor:set-standard-style-list-delta style-name delta) - (send c set-editor e) (send e insert example-text) (send e set-position 0) @@ -286,75 +278,14 @@ (hash-table-put! prefs-panel-mapping (string->symbol name) panel) panel)) - ;; prefs-table maps tab-name symbols to either 'too-late or a listof symbols/defaults. - ;; 'too-late indicates that the preference window has been created and - ;; additions can no longer be made. - (define prefs-table (make-hash-table)) - ;; pref-added-table maps tab-name symbols to booleans. - ;; #t iff the preferences:add call has been made. This is to avoid - ;; calling add multiple times. - (define pref-added-table (make-hash-table)) - - (define (add-staged tab-name symbols/defaults) - (let* ((tab-name-symbol (string->symbol tab-name)) - (active-pref (get-full-pref-name tab-name "active")) - (current (hash-table-get prefs-table tab-name-symbol (lambda () #f)))) - (when (eq? 'too-late current) - (error 'color-prefs:add-staged - "cannot be invoked after the preferences have already been created for this tab.")) - (unless current - (preferences:set-default active-pref #t (lambda (x) #t)) - (preferences:add-callback active-pref - (lambda (_ on?) - (do-active-pref-callbacks tab-name on?)))) - (for-each (lambda (s/d) - (set-default (get-full-pref-name tab-name (car s/d)) (cadr s/d))) - symbols/defaults) - (for-each (lambda (s/d) - (preferences:set-un/marshall (get-full-pref-name tab-name (car s/d)) - marshall-style unmarshall-style)) - symbols/defaults) - (for-each (lambda (s/d) - (editor:set-standard-style-list-delta - (get-full-style-name tab-name (car s/d)) - (preferences:get (get-full-pref-name tab-name (car s/d))))) - symbols/defaults) - (hash-table-put! prefs-table - tab-name-symbol - (append (if current current null) symbols/defaults)) - (lambda () - (unless (hash-table-get pref-added-table tab-name-symbol (lambda () #f)) - (hash-table-put! pref-added-table tab-name-symbol #t) - (preferences:add-panel - (list "Junk" sc-syntax-coloring tab-name) - (lambda (p) - (let ((vp (new vertical-panel% (parent p)))) - (build-many-color-selection-panels - (map car (hash-table-get prefs-table - tab-name-symbol - (lambda () null))) - tab-name - vp) - (let ((cb (new check-box% - (parent vp) - (label sc-color-syntax-interactively) - (callback (lambda (checkbox y) - (preferences:set - active-pref - (send checkbox get-value))))))) - (send cb set-value (preferences:get active-pref))) - (hash-table-put! prefs-table tab-name-symbol 'too-late) - vp))))))) - - (define (add tab-name symbols/defaults) - ((add-staged tab-name symbols/defaults))) - - (define (get-full-pref-name tab-name pref-name) - (string->symbol (get-full-style-name tab-name pref-name))) - - (define (get-full-style-name tab-name pref-name) - (format "syntax-coloring:~a:~a" tab-name pref-name)) + ;; see docs + (define (register-color-pref pref-name style-name color) + (let ([sd (new style-delta%)]) + (send sd set-delta-foreground color) + (preferences:set-default pref-name sd (lambda (x) (is-a? x style-delta%))) + (preferences:set-un/marshall pref-name marshall-style unmarshall-style) + (editor:set-standard-style-list-delta style-name sd))) ;; The following 4 defines are a mini-prefs system that uses a weak hash table ;; so the preferences won't hold on to a text when it should otherwise be GCed. diff --git a/collects/framework/private/color.ss b/collects/framework/private/color.ss index deb458a7..1b8adb31 100644 --- a/collects/framework/private/color.ss +++ b/collects/framework/private/color.ss @@ -18,7 +18,8 @@ [icon : framework:icon^] [mode : framework:mode^] [text : framework:text^] - [color-prefs : framework:color-prefs^]) + [color-prefs : framework:color-prefs^] + [scheme : framework:scheme^]) (rename [-text<%> text<%>] [-text% text%] @@ -169,7 +170,7 @@ (set! colors (cons (let ((color (send (get-style-list) find-named-style - (color-prefs:get-full-style-name tab-name type))) + (scheme:short-sym->style-name type))) (sp (+ in-start-pos (sub1 new-token-start))) (ep (+ in-start-pos (sub1 new-token-end)))) (lambda () @@ -292,8 +293,7 @@ (unless force-stop? (set! stopped? #f) (reset-tokens) - (set! should-color? - (preferences:get (color-prefs:get-full-pref-name tab-name- "active"))) + (set! should-color? (preferences:get 'framework:coloring-active)) (set! tab-name tab-name-) (set! get-token get-token-) (set! pairs pairs-) @@ -321,8 +321,8 @@ (define/public (freeze-colorer) (when (is-locked?) (error 'freeze-colorer "called on a locked color:text<%>.")) - (when (in-edit-sequence?) - (error 'freeze-colorer "called on a color:text<%> while in an edit sequence.")) + #;(when (in-edit-sequence?) + (error 'freeze-colorer "called on a color:text<%> while in an edit sequence.")) (unless frozen? (finish-now) (set! frozen? #t))) diff --git a/collects/framework/private/editor.ss b/collects/framework/private/editor.ss index 0eafe630..49530188 100644 --- a/collects/framework/private/editor.ss +++ b/collects/framework/private/editor.ss @@ -373,14 +373,15 @@ ;; set-standard-style-list-delta : string (is-a?/c style-delta<%>) -> void (define (set-standard-style-list-delta name delta) - (let* ([style-list (editor:get-standard-style-list)] + (let* ([style-list (get-standard-style-list)] [style (send style-list find-named-style name)]) (if style (send style set-delta delta) (send style-list new-named-style name (send style-list find-or-create-style (send style-list find-named-style "Standard") - delta))))) + delta))) + (void))) (define -keymap<%> (interface (basic<%>) get-keymaps)) (define keymap-mixin diff --git a/collects/framework/private/main.ss b/collects/framework/private/main.ss index 10e5a793..284fa831 100644 --- a/collects/framework/private/main.ss +++ b/collects/framework/private/main.ss @@ -184,6 +184,19 @@ (lambda (x) (or (eq? x 'common) (eq? x 'std)))) + + ;; scheme prefs + + (for-each (lambda (line) + (let ([sym (car line)] + [color (cadr line)]) + (color-prefs:register-color-pref (scheme:short-sym->pref-name sym) + (scheme:short-sym->style-name sym) + color))) + (scheme:get-color-prefs-table)) + (preferences:set-default 'framework:coloring-active #t boolean?) + ;; need to add in the editor checkbox. + ;; groups @@ -217,5 +230,4 @@ (preferences:set 'framework:file-dialogs 'std) (preferences:set 'framework:exit-when-no-frames #t) - (scheme:add-coloring-preferences-panel) (void)))) diff --git a/collects/framework/private/scheme.ss b/collects/framework/private/scheme.ss index 7cd5ce2b..7edfceeb 100644 --- a/collects/framework/private/scheme.ss +++ b/collects/framework/private/scheme.ss @@ -258,43 +258,34 @@ ;;; ;;; ;;; ;;; ;;; ;; ; ;; ;;; ; ;;; ;;; ;; ;; ;;; - ;; This adds the preferences that scheme:text% needs for coloring - ;; It returns a thunk that, when invoked will setup the panel in the - ;; preferences dialog. - ;; It uses the set! trick because it needs to not call add-staged - ;; until the preferences has been turned on in main.ss - (define add-coloring-pref-state #f) + (define color-prefs-table + `((symbol ,(make-object color% 38 38 128) ,(string-constant scheme-mode-color-symbol)) + (keyword ,(make-object color% 38 38 128) ,(string-constant scheme-mode-color-keyword)) + (comment ,(make-object color% 194 116 31) ,(string-constant scheme-mode-color-comment)) + (string ,(make-object color% "forestgreen") ,(string-constant scheme-mode-color-string)) + (constant ,(make-object color% "forestgreen") ,(string-constant scheme-mode-color-constant)) + (parenthesis ,(make-object color% "brown") ,(string-constant scheme-mode-color-parenthesis)) + (error ,(make-object color% "red") ,(string-constant scheme-mode-color-error)) + (other ,(make-object color% "black") ,(string-constant scheme-mode-color-other)))) + (define (get-color-prefs-table) color-prefs-table) + + (define (short-sym->pref-name sym) (string->symbol (short-sym->style-name sym))) + (define (short-sym->style-name sym) (format "syntax-coloring:Scheme:~a" sym)) + (define (add-coloring-preferences-panel) - (cond - (add-coloring-pref-state - (add-coloring-pref-state)) - (else - (set! add-coloring-pref-state - (color-prefs:add-staged - "Scheme" - `((symbol ,(color-prefs:make-style-delta "navy" #f #f #f)) - (keyword ,(color-prefs:make-style-delta "navy" #f #f #f)) - (comment ,(color-prefs:make-style-delta (make-object color% 0 105 255) #f #f #f)) - (string ,(color-prefs:make-style-delta "ForestGreen" #f #f #f)) - (constant ,(color-prefs:make-style-delta (make-object color% 51 135 39) #f #f #f)) - (parenthesis ,(color-prefs:make-style-delta "brown" #f #f #f)) - (error ,(color-prefs:make-style-delta "red" #f #f #f)) - (other ,(color-prefs:make-style-delta "black" #f #f #f)))))))) - - - ;; for check syntax (to be moved elsewhere) - (color-prefs:add-staged - "Scheme" - `((lexically-bound-variable - ,(color-prefs:make-style-delta (make-object color% 255 0 0) #f #f #f)) - (lexically-bound-syntax - ,(color-prefs:make-style-delta (make-object color% 0 0 255) #f #f #f)) - (imported-syntax - ,(color-prefs:make-style-delta (make-object color% 255 0 255) #f #f #f)) - (imported-variable - ,(color-prefs:make-style-delta (make-object color% 0 255 255) #f #f #f)))) - - + (color-prefs:add-to-preferences-panel + "Scheme" + (lambda (parent) + (for-each + (lambda (line) + (let ([sym (car line)]) + (color-prefs:build-color-selection-panel + parent + (short-sym->pref-name sym) + (short-sym->style-name sym) + (format "~a" sym)))) + color-prefs-table)))) + (define-struct string/pos (string pos)) (define -text<%> diff --git a/collects/framework/private/sig.ss b/collects/framework/private/sig.ss index b194fd99..0b8c2be1 100644 --- a/collects/framework/private/sig.ss +++ b/collects/framework/private/sig.ss @@ -521,16 +521,12 @@ (define-signature framework:color-prefs-class^ ()) (define-signature framework:color-prefs-fun^ - (make-style-delta ;; to be gone - add ;; to be gone - add-staged ;; to be gone + (register-color-pref add-to-preferences-panel add-preferences-panel build-color-selection-panel register-active-pref-callback - remove-active-pref-callback - get-full-pref-name - get-full-style-name)) + remove-active-pref-callback)) (define-signature framework:color-prefs^ ((open framework:color-prefs-class^) (open framework:color-prefs-fun^))) @@ -555,7 +551,11 @@ get-keymap setup-keymap add-preferences-panel - add-coloring-preferences-panel)) + add-coloring-preferences-panel + + get-color-prefs-table + short-sym->pref-name + short-sym->style-name)) (define-signature framework:scheme^ ((open framework:scheme-class^) (open framework:scheme-fun^)))