add support for color schemes to the framework and use it in DrRacket
This commit is contained in:
Robby Findler
parent
136c18f7e9
commit
1186f23543
|
|
@ -12,3 +12,12 @@
|
|||
(define release-note-files (list (list "DrRacket" "HISTORY.txt")))
|
||||
|
||||
(define copy-man-pages '("drracket.1"))
|
||||
|
||||
(define framework:color-schemes
|
||||
(list (hash
|
||||
'name 'modern-color-scheme
|
||||
'colors
|
||||
'((framework:syntax-color:scheme:symbol #(211 72 255))
|
||||
(framework:syntax-color:scheme:constant #(211 72 255))
|
||||
(framework:syntax-color:scheme:comment #(194 158 31))
|
||||
(framework:syntax-color:scheme:parenthesis #(0 150 255))))))
|
||||
|
|
|
|||
|
|
@ -263,6 +263,7 @@
|
|||
|
||||
|
||||
(drracket:font:setup-preferences)
|
||||
(color-prefs:add-color-scheme-preferences-panel)
|
||||
(color-prefs:add-background-preferences-panel)
|
||||
(racket:add-preferences-panel)
|
||||
(racket:add-coloring-preferences-panel)
|
||||
|
|
@ -588,19 +589,19 @@
|
|||
(define repl-error-pref 'drracket:read-eval-print-loop:error-color)
|
||||
(define repl-out-pref 'drracket:read-eval-print-loop:out-color)
|
||||
(define repl-value-pref 'drracket:read-eval-print-loop:value-color)
|
||||
(color-prefs:register-color-preference repl-value-pref
|
||||
"text:ports value"
|
||||
(make-object color% 0 0 175)
|
||||
(make-object color% 57 89 216))
|
||||
(color-prefs:register-color-preference repl-error-pref
|
||||
"text:ports err"
|
||||
(let ([sd (make-object style-delta% 'change-italic)])
|
||||
(send sd set-delta-foreground (make-object color% 255 0 0))
|
||||
sd))
|
||||
(color-prefs:register-color-preference repl-out-pref
|
||||
"text:ports out"
|
||||
(make-object color% 150 0 150)
|
||||
(make-object color% 192 46 214))
|
||||
(color-prefs:add-color-scheme-entry repl-value-pref
|
||||
#:style "text:ports value"
|
||||
(make-object color% 0 0 175)
|
||||
(make-object color% 57 89 216))
|
||||
(color-prefs:add-color-scheme-entry repl-error-pref
|
||||
#:style "text:ports err"
|
||||
(make-object color% 255 0 0)
|
||||
(make-object color% 255 0 0)
|
||||
#:italic? #t)
|
||||
(color-prefs:add-color-scheme-entry repl-out-pref
|
||||
#:style "text:ports out"
|
||||
(make-object color% 150 0 150)
|
||||
(make-object color% 192 46 214))
|
||||
(color-prefs:add-to-preferences-panel
|
||||
(string-constant repl-colors)
|
||||
(λ (parent)
|
||||
|
|
@ -621,15 +622,15 @@
|
|||
(define test-coverage-on-style-pref (string->symbol drracket:debug:test-coverage-on-style-name))
|
||||
(define test-coverage-off-style-pref (string->symbol drracket:debug:test-coverage-off-style-name))
|
||||
|
||||
(color-prefs:register-color-preference test-coverage-on-style-pref
|
||||
drracket:debug:test-coverage-on-style-name
|
||||
(send the-color-database find-color "black")
|
||||
(send the-color-database find-color "white"))
|
||||
(color-prefs:register-color-preference test-coverage-off-style-pref
|
||||
drracket:debug:test-coverage-off-style-name
|
||||
(send the-color-database find-color "orange")
|
||||
(send the-color-database find-color "indianred")
|
||||
#:background (send the-color-database find-color "black"))
|
||||
(color-prefs:add-color-scheme-entry test-coverage-on-style-pref
|
||||
#:style drracket:debug:test-coverage-on-style-name
|
||||
"black"
|
||||
"white")
|
||||
(color-prefs:add-color-scheme-entry test-coverage-off-style-pref
|
||||
#:style drracket:debug:test-coverage-off-style-name
|
||||
"orange"
|
||||
"indianred"
|
||||
#:background "black")
|
||||
(color-prefs:add-to-preferences-panel
|
||||
"Module Language"
|
||||
(λ (parent)
|
||||
|
|
@ -640,7 +641,8 @@
|
|||
(color-prefs:build-color-selection-panel parent
|
||||
test-coverage-off-style-pref
|
||||
drracket:debug:test-coverage-off-style-name
|
||||
(string-constant test-coverage-off))))
|
||||
(string-constant test-coverage-off)
|
||||
#:background? #t)))
|
||||
|
||||
(drracket:module-language:initialize-prefs-panel)
|
||||
|
||||
|
|
@ -707,6 +709,10 @@
|
|||
(when (eq? (system-type) 'macosx)
|
||||
(new separator-menu-item% [parent windows-menu])))))
|
||||
|
||||
;; this needs to happen after all of the earlier preferences setup
|
||||
;; so that the color-prefs knowns about all the new colors names
|
||||
(color-prefs:register-info-based-color-schemes)
|
||||
|
||||
;; Check for any files lost last time.
|
||||
;; Ignore the framework's empty frames test, since
|
||||
;; the autosave information window may appear and then
|
||||
|
|
|
|||
|
|
@ -135,43 +135,43 @@ If the namespace does not, they are colored the unbound color.
|
|||
both-obligation-style-name
|
||||
cs-both-obligation-color))
|
||||
|
||||
(color-prefs:register-color-preference lexically-bound-variable-style-pref
|
||||
lexically-bound-variable-style-name
|
||||
(make-object color% 81 112 203)
|
||||
(make-object color% 50 163 255))
|
||||
(color-prefs:register-color-preference set!d-variable-style-pref
|
||||
set!d-variable-style-name
|
||||
(send the-color-database find-color "firebrick")
|
||||
(send the-color-database find-color "pink"))
|
||||
(color-prefs:register-color-preference unused-require-style-pref
|
||||
unused-require-style-name
|
||||
(send the-color-database find-color "red")
|
||||
(send the-color-database find-color "pink"))
|
||||
(color-prefs:register-color-preference free-variable-style-pref
|
||||
free-variable-style-name
|
||||
(send the-color-database find-color "red")
|
||||
(send the-color-database find-color "pink"))
|
||||
(color-prefs:add-color-scheme-entry lexically-bound-variable-style-pref
|
||||
#:style lexically-bound-variable-style-name
|
||||
(make-object color% 81 112 203)
|
||||
(make-object color% 50 163 255))
|
||||
(color-prefs:add-color-scheme-entry set!d-variable-style-pref
|
||||
#:style set!d-variable-style-name
|
||||
(send the-color-database find-color "firebrick")
|
||||
(send the-color-database find-color "pink"))
|
||||
(color-prefs:add-color-scheme-entry unused-require-style-pref
|
||||
#:style unused-require-style-name
|
||||
(send the-color-database find-color "red")
|
||||
(send the-color-database find-color "pink"))
|
||||
(color-prefs:add-color-scheme-entry free-variable-style-pref
|
||||
#:style free-variable-style-name
|
||||
(send the-color-database find-color "red")
|
||||
(send the-color-database find-color "pink"))
|
||||
|
||||
(color-prefs:register-color-preference imported-variable-style-pref
|
||||
imported-variable-style-name
|
||||
(make-object color% 68 0 203)
|
||||
(make-object color% 166 0 255))
|
||||
(color-prefs:register-color-preference my-obligation-style-pref
|
||||
my-obligation-style-name
|
||||
(send the-color-database find-color "firebrick")
|
||||
(send the-color-database find-color "pink"))
|
||||
(color-prefs:register-color-preference their-obligation-style-pref
|
||||
their-obligation-style-name
|
||||
(make-object color% 0 116 0)
|
||||
(send the-color-database find-color "limegreen"))
|
||||
(color-prefs:register-color-preference unk-obligation-style-pref
|
||||
unk-obligation-style-name
|
||||
(send the-color-database find-color "black")
|
||||
(send the-color-database find-color "white"))
|
||||
(color-prefs:register-color-preference both-obligation-style-pref
|
||||
both-obligation-style-name
|
||||
(make-object color% 139 142 28)
|
||||
(send the-color-database find-color "khaki"))
|
||||
(color-prefs:add-color-scheme-entry imported-variable-style-pref
|
||||
#:style imported-variable-style-name
|
||||
(make-object color% 68 0 203)
|
||||
(make-object color% 166 0 255))
|
||||
(color-prefs:add-color-scheme-entry my-obligation-style-pref
|
||||
#:style my-obligation-style-name
|
||||
(send the-color-database find-color "firebrick")
|
||||
(send the-color-database find-color "pink"))
|
||||
(color-prefs:add-color-scheme-entry their-obligation-style-pref
|
||||
#:style their-obligation-style-name
|
||||
(make-object color% 0 116 0)
|
||||
(send the-color-database find-color "limegreen"))
|
||||
(color-prefs:add-color-scheme-entry unk-obligation-style-pref
|
||||
#:style unk-obligation-style-name
|
||||
(send the-color-database find-color "black")
|
||||
(send the-color-database find-color "white"))
|
||||
(color-prefs:add-color-scheme-entry both-obligation-style-pref
|
||||
#:style both-obligation-style-name
|
||||
(make-object color% 139 142 28)
|
||||
(send the-color-database find-color "khaki"))
|
||||
|
||||
(define tool@
|
||||
(unit
|
||||
|
|
|
|||
|
|
@ -570,8 +570,18 @@ has.
|
|||
@index{modes}
|
||||
@index{scheme mode}
|
||||
@index{racket mode}
|
||||
@index{definitions-text-surrogate}
|
||||
|
||||
@subsection{Color Schemes}
|
||||
|
||||
DrRacket uses the framework's color schemes to colorize
|
||||
source text and other aspects of itself. See
|
||||
@racket[color-prefs:register-info-based-color-schemes] for
|
||||
details on how to add new color schemes via @filepath{info.rkt}
|
||||
files.
|
||||
|
||||
@subsection{General-purpose Modes}
|
||||
|
||||
@index{definitions-text-surrogate}
|
||||
DrRacket provides support for multiple editor modes based on the
|
||||
@tt{#lang} line at the beginning of the editor. If the
|
||||
@onscreen{Modes} submenu of the @onscreen{Edit} menu has
|
||||
|
|
|
|||
|
|
@ -28,7 +28,8 @@
|
|||
framework/decorated-editor-snip
|
||||
framework/private/decorated-editor-snip))
|
||||
|
||||
(require (for-doc scheme/base scribble/manual framework/private/mapdesc))
|
||||
(require (for-doc racket/base scribble/manual framework/private/mapdesc
|
||||
setup/getinfo racket/pretty))
|
||||
|
||||
(provide-signature-elements
|
||||
(prefix application: framework:application-class^)
|
||||
|
|
@ -711,7 +712,7 @@
|
|||
|
||||
(proc-doc/names
|
||||
frame:reorder-menus
|
||||
((is-a?/c frame%) . -> . void?)
|
||||
(-> (is-a?/c frame%) void?)
|
||||
(frame)
|
||||
@{Re-orders the menus in a frame. It moves the ``File'' and ``Edit'' menus
|
||||
to the front of the menubar and moves the ``Windows'' and ``Help'' menus to
|
||||
|
|
@ -1621,7 +1622,7 @@
|
|||
|
||||
(proc-doc/names
|
||||
editor:set-standard-style-list-delta
|
||||
(string? (is-a?/c style-delta%) . -> . void?)
|
||||
(-> string? (is-a?/c style-delta%) void?)
|
||||
(name delta)
|
||||
@{Finds (or creates) the style named by @racket[name] in the result of
|
||||
@racket[editor:get-standard-style-list] and sets its delta to
|
||||
|
|
@ -1756,7 +1757,7 @@
|
|||
@racket[preferences:set-un/marshall] with appropriate arguments to register
|
||||
the preference.})
|
||||
|
||||
(proc-doc/names
|
||||
(proc-doc/names
|
||||
color-prefs:register-color-preference
|
||||
(->* (symbol? string? (or/c (is-a?/c color%) (is-a?/c style-delta%)))
|
||||
((or/c string? (is-a?/c color%) #f)
|
||||
|
|
@ -1787,10 +1788,8 @@
|
|||
@racket[white-on-black-color] to register this preference with
|
||||
@racket[color-prefs:set-default/color-scheme].
|
||||
|
||||
If either @racket[background] is
|
||||
not @racket[#f], then it is used to construct the default background color
|
||||
for the style delta.
|
||||
|
||||
If @racket[background] is not @racket[#f], then it is used to construct the
|
||||
default background color for the style delta.
|
||||
})
|
||||
|
||||
(proc-doc/names
|
||||
|
|
@ -1849,7 +1848,157 @@
|
|||
(-> any)
|
||||
()
|
||||
@{Sets the colors registered by @racket[color-prefs:register-color-preference]
|
||||
to their black-on-white variety.}))
|
||||
to their black-on-white variety.})
|
||||
|
||||
(proc-doc
|
||||
color-prefs:add-color-scheme-entry
|
||||
(->i ([name symbol?]
|
||||
[black-on-white-color (or/c string? (is-a?/c color%))]
|
||||
[white-on-black-color (or/c string? (is-a?/c color%))])
|
||||
(#:style
|
||||
[style (or/c #f string?)]
|
||||
#:bold? [bold? (style) (if style boolean? #f)]
|
||||
#:underline? [underline? (style) (if style boolean? #f)]
|
||||
#:italic? [italic? (style) (if style boolean? #f)]
|
||||
#:background
|
||||
[background (style)
|
||||
(if style
|
||||
(or/c #f string? (is-a?/c color%))
|
||||
#f)])
|
||||
[result void?])
|
||||
(#f #f #f #f #f)
|
||||
@{Registers a new color or style named @racket[name] for use in the color schemes.
|
||||
If @racket[style] is provided, a new style is registered; if not a color is
|
||||
registered.})
|
||||
|
||||
(proc-doc
|
||||
color-prefs:add-color-scheme-preferences-panel
|
||||
(-> void?)
|
||||
@{Adds a panel for choosing a color-scheme to the preferences dialog.})
|
||||
|
||||
(proc-doc
|
||||
color-prefs:register-info-based-color-schemes
|
||||
(-> void?)
|
||||
@{Reads
|
||||
the @filepath{info.rkt} file in each collection, looking for the key
|
||||
@index{framework:color-schemes}
|
||||
@racket['framework:color-schemes]. Each definition must bind
|
||||
a list of hash tables, each of which introduces a new
|
||||
color scheme. Each hash table should have keys that specify
|
||||
details of the color scheme, as follows:
|
||||
@itemlist[@item{@racket['name]: must be either a string or a symbol;
|
||||
if it is a symbol, it is passed to @racket[dynamic-string-constant]
|
||||
to get the name; otherwise it is used as the name directly.
|
||||
If absent, the name of the directory containing the @filepath{info.rkt}
|
||||
file is used as the name.}
|
||||
@item{@racket['white-on-black-base?]: must be a boolean indicating if this
|
||||
color-scheme is based on an inverted color scheme. If absent, it
|
||||
is @racket[#f].}
|
||||
@item{@racket['example]: must be a string and is used in the preferences dialog
|
||||
to show an example of the color scheme. If absent, the string used in
|
||||
the ``Classic'' color scheme is used.}
|
||||
@item{@racket['colors]: must be a non-empty list whose first position
|
||||
is a symbol, naming a color or style. The rest of the elements describe
|
||||
the style or color. In either case, an element may be a vector of three
|
||||
bytes: this describes a color (in r/g/b order) with an alpha value of
|
||||
@racket[1.0]. The vector may also have three bytes followed by a real
|
||||
number between @racket[0] and @racket[1], which is used as the alpha
|
||||
value. If the name corresponds to a style, then the list may also contain
|
||||
the symbols @racket['bold], @racket['italic], or @racket['underline].}]
|
||||
|
||||
The names of the colors and styles are extensible; new ones can be added by calling
|
||||
@racket[color-prefs:add-color-scheme-entry]. When
|
||||
@racket[color-prefs:register-info-based-color-schemes]
|
||||
is called, it logs the active set of color names and style names to the @tt{color-scheme}
|
||||
logger at the info level. So, for example, starting up DrRacket like this:
|
||||
@tt{racket -W info@"@"color-scheme -l drracket} will print out the styles used in your
|
||||
version of DrRacket.
|
||||
|
||||
As an example, this is the specification of the @racket["Modern"] style:
|
||||
@(let ()
|
||||
(define pth (collection-file-path "info.rkt" "drracket"))
|
||||
(define-values (base name dir?) (split-path pth))
|
||||
(define info (get-info/full base))
|
||||
(unless info (error 'framework/main.rkt "could not find example for modern color scheme"))
|
||||
(parameterize ([pretty-print-columns 60])
|
||||
(codeblock (pretty-format (info 'framework:color-schemes)))))})
|
||||
|
||||
(proc-doc/names
|
||||
color-prefs:set-current-color-scheme
|
||||
(-> symbol? void?)
|
||||
(name)
|
||||
@{Sets
|
||||
the current color scheme to @racket[name], if @racket[name] is
|
||||
@racket[color-prefs:known-color-scheme-name?]. Otherwise, does nothing.})
|
||||
|
||||
(proc-doc
|
||||
color-prefs:get-current-color-scheme
|
||||
(-> color-prefs:color-scheme-style-name?)
|
||||
@{Returns the current color scheme's name.})
|
||||
|
||||
(proc-doc/names
|
||||
color-prefs:known-color-scheme-name?
|
||||
(-> any/c boolean?)
|
||||
(name)
|
||||
@{Returns @racket[#t] if the input is a @racket[symbol?] that names
|
||||
a color or style that is part of the current color scheme.
|
||||
|
||||
In order to return @racket[#t], @racket[name] must have been
|
||||
passed as the first argument to @racket[color-prefs:add-color-scheme-entry].})
|
||||
|
||||
(proc-doc/names
|
||||
color-prefs:color-scheme-style-name?
|
||||
(-> any/c boolean?)
|
||||
(name)
|
||||
@{Returns @racket[#t] if @racket[name] is a known color scheme name,
|
||||
and is connected to a style.
|
||||
|
||||
In order to return @racket[#t], @racket[name] must have been
|
||||
passed as the first argument to @racket[color-prefs:add-color-scheme-entry]
|
||||
and the @racket[#:style] argument must have also been passed.})
|
||||
|
||||
(proc-doc
|
||||
color-prefs:lookup-in-color-scheme
|
||||
(->i ([name color-prefs:known-color-scheme-name?])
|
||||
()
|
||||
[result (name)
|
||||
(if (color-prefs:color-scheme-style-name? name)
|
||||
(is-a?/c style-delta%)
|
||||
(is-a?/c color%))])
|
||||
@{Returns the current style delta or color associated with @racket[name].})
|
||||
|
||||
(proc-doc
|
||||
color-prefs:set-in-color-scheme
|
||||
(->i ([name color-prefs:known-color-scheme-name?]
|
||||
[new-val (name)
|
||||
(if (color-prefs:color-scheme-style-name? name)
|
||||
(is-a?/c style-delta%)
|
||||
(is-a?/c color%))])
|
||||
()
|
||||
[result void?])
|
||||
@{Updates the current color or style delta associated with
|
||||
@racket[name] in the current color scheme.})
|
||||
|
||||
(proc-doc
|
||||
color-prefs:register-color-scheme-entry-change-callback
|
||||
(->i ([name color-prefs:known-color-scheme-name?]
|
||||
[fn (name)
|
||||
(-> (if (color-prefs:color-scheme-style-name? name)
|
||||
(is-a?/c style-delta%)
|
||||
(is-a?/c color%))
|
||||
any)])
|
||||
([weak? boolean?])
|
||||
[result void?])
|
||||
(#f)
|
||||
@{Registers a callback that is invoked whenever the color mapped by
|
||||
@racket[name] changes. Changes may happen due to calls to
|
||||
@racket[color-prefs:set-in-color-scheme] or due to calls to
|
||||
@racket[color-prefs:set-current-color-scheme].
|
||||
|
||||
If @racket[weak?] is @racket[#t], the @racket[fn] argument is held
|
||||
onto weakly; otherwise it is held onto strongly.})
|
||||
)
|
||||
|
||||
|
||||
(define-syntax (racket:-reprovides stx)
|
||||
#`(provide
|
||||
|
|
|
|||
|
|
@ -6,7 +6,8 @@
|
|||
|
||||
(import mred^
|
||||
[prefix frame: framework:frame^]
|
||||
[prefix text: framework:text^])
|
||||
[prefix text: framework:text^]
|
||||
[prefix color-prefs: framework:color-prefs^])
|
||||
|
||||
(export (rename framework:canvas^
|
||||
(-color% color%)))
|
||||
|
|
@ -20,11 +21,12 @@
|
|||
|
||||
(define color-mixin
|
||||
(mixin (basic<%>) (color<%>)
|
||||
(define callback (λ (p v) (set-canvas-background v)))
|
||||
(define callback (λ (v) (set-canvas-background v)))
|
||||
(super-new)
|
||||
(inherit set-canvas-background)
|
||||
(set-canvas-background (preferences:get 'framework:basic-canvas-background))
|
||||
(preferences:add-callback 'framework:basic-canvas-background callback #t)))
|
||||
(set-canvas-background (color-prefs:lookup-in-color-scheme 'framework:basic-canvas-background))
|
||||
(color-prefs:register-color-scheme-entry-change-callback
|
||||
'framework:basic-canvas-background callback #t)))
|
||||
|
||||
(define delegate<%> (interface (basic<%>)))
|
||||
|
||||
|
|
|
|||
|
|
@ -1,8 +1,14 @@
|
|||
#lang racket/unit
|
||||
(require mzlib/class
|
||||
mred
|
||||
(require racket/class
|
||||
racket/gui/base
|
||||
string-constants
|
||||
racket/match
|
||||
racket/contract/base
|
||||
racket/set
|
||||
setup/getinfo
|
||||
setup/collects
|
||||
string-constants
|
||||
racket/pretty
|
||||
"../preferences.rkt"
|
||||
"sig.rkt")
|
||||
|
||||
|
|
@ -19,12 +25,25 @@
|
|||
|
||||
;; build-color-selection-panel : (is-a?/c area-container<%>) symbol string string -> void
|
||||
;; constructs a panel containg controls to configure the preferences panel.
|
||||
(define (build-color-selection-panel parent pref-sym style-name example-text #:background? [background? #f])
|
||||
(define (build-color-selection-panel parent pref-sym style-name example-text
|
||||
#:background? [background? #f])
|
||||
(define (get-from-pref-sym)
|
||||
(if (set-member? known-style-names pref-sym)
|
||||
(lookup-in-color-scheme pref-sym)
|
||||
(preferences:get pref-sym)))
|
||||
(define (set-via-pref-sym delta)
|
||||
(if (set-member? known-style-names pref-sym)
|
||||
(set-in-color-scheme pref-sym delta)
|
||||
(preferences:set pref-sym delta)))
|
||||
(define (add-pref-sym-callback f)
|
||||
(if (set-member? known-style-names pref-sym)
|
||||
(register-color-scheme-entry-change-callback pref-sym f)
|
||||
(preferences:add-callback pref-sym (λ (p sd) (f sd)))))
|
||||
(define (update-style-delta func)
|
||||
(let ([working-delta (new style-delta%)])
|
||||
(send working-delta copy (preferences:get pref-sym))
|
||||
(send working-delta copy (get-from-pref-sym))
|
||||
(func working-delta)
|
||||
(preferences:set pref-sym working-delta)))
|
||||
(set-via-pref-sym working-delta)))
|
||||
(define hp (new horizontal-panel%
|
||||
[parent parent]
|
||||
[style '(border)]
|
||||
|
|
@ -138,7 +157,7 @@
|
|||
hp)]
|
||||
[callback
|
||||
(λ (color-button evt)
|
||||
(let* ([add (send (preferences:get pref-sym) get-foreground-add)]
|
||||
(let* ([add (send (get-from-pref-sym) get-foreground-add)]
|
||||
[color (make-object color%
|
||||
(send add get-r)
|
||||
(send add get-g)
|
||||
|
|
@ -147,7 +166,8 @@
|
|||
(get-color-from-user
|
||||
(format (string-constant syntax-coloring-choose-color) example-text)
|
||||
(send color-button get-top-level-window)
|
||||
color)])
|
||||
color
|
||||
'(alpha))])
|
||||
(when users-choice
|
||||
(update-style-delta
|
||||
(λ (delta)
|
||||
|
|
@ -162,7 +182,7 @@
|
|||
hp)]
|
||||
[callback
|
||||
(λ (color-button evt)
|
||||
(let* ([add (send (preferences:get pref-sym) get-background-add)]
|
||||
(let* ([add (send (get-from-pref-sym) get-background-add)]
|
||||
[color (make-object color%
|
||||
(send add get-r)
|
||||
(send add get-g)
|
||||
|
|
@ -171,7 +191,8 @@
|
|||
(get-color-from-user
|
||||
(format (string-constant syntax-coloring-choose-color) example-text)
|
||||
(send color-button get-top-level-window)
|
||||
color)])
|
||||
color
|
||||
'(alpha))])
|
||||
(when users-choice
|
||||
(update-style-delta
|
||||
(λ (delta)
|
||||
|
|
@ -197,12 +218,11 @@
|
|||
(send c min-height 50)
|
||||
(send c stretchable-height #f))
|
||||
|
||||
(preferences:add-callback
|
||||
pref-sym
|
||||
(λ (p sd)
|
||||
(send slant-check set-value (or (eq? (send style get-style) 'slant)
|
||||
(eq? (send style get-style) 'italic)))
|
||||
(send bold-check set-value (eq? (send sd get-weight-on) 'bold))
|
||||
(add-pref-sym-callback
|
||||
(λ (sd)
|
||||
(send slant-check set-value (or (equal? (send style get-style) 'slant)
|
||||
(equal? (send style get-style) 'italic)))
|
||||
(send bold-check set-value (equal? (send sd get-weight-on) 'bold))
|
||||
(send underline-check set-value (send sd get-underlined-on))
|
||||
(send smoothing-menu set-selection (smoothing->index (send sd get-smoothing-on)))))
|
||||
(void))
|
||||
|
|
@ -304,26 +324,28 @@
|
|||
|
||||
style))
|
||||
|
||||
(define (make-style-delta color bold? underline? italic?)
|
||||
(let ((sd (make-object style-delta%)))
|
||||
(send sd set-delta-foreground color)
|
||||
(cond
|
||||
(bold?
|
||||
(send sd set-weight-on 'bold)
|
||||
(send sd set-weight-off 'base))
|
||||
(else
|
||||
(send sd set-weight-on 'base)
|
||||
(send sd set-weight-off 'bold)))
|
||||
(send sd set-underlined-on underline?)
|
||||
(send sd set-underlined-off (not underline?))
|
||||
(cond
|
||||
(italic?
|
||||
(send sd set-style-on 'italic)
|
||||
(send sd set-style-off 'base))
|
||||
(else
|
||||
(send sd set-style-on 'base)
|
||||
(send sd set-style-off 'italic)))
|
||||
sd))
|
||||
(define (make-style-delta color bold? underline? italic? #:background [background #f])
|
||||
(define sd (make-object style-delta%))
|
||||
(send sd set-delta-foreground color)
|
||||
(cond
|
||||
[bold?
|
||||
(send sd set-weight-on 'bold)
|
||||
(send sd set-weight-off 'base)]
|
||||
[else
|
||||
(send sd set-weight-on 'base)
|
||||
(send sd set-weight-off 'bold)])
|
||||
(send sd set-underlined-on underline?)
|
||||
(send sd set-underlined-off (not underline?))
|
||||
(cond
|
||||
[italic?
|
||||
(send sd set-style-on 'italic)
|
||||
(send sd set-style-off 'base)]
|
||||
[else
|
||||
(send sd set-style-on 'base)
|
||||
(send sd set-style-off 'italic)])
|
||||
(when background
|
||||
(send sd set-delta-background background))
|
||||
sd)
|
||||
|
||||
(define (add-background-preferences-panel)
|
||||
(preferences:add-panel
|
||||
|
|
@ -366,25 +388,8 @@
|
|||
'framework:paren-color-scheme
|
||||
(λ (p v)
|
||||
(update-choice v)))
|
||||
(update-choice (preferences:get 'framework:paren-color-scheme)))
|
||||
|
||||
(let ([hp (new horizontal-panel%
|
||||
[parent vp]
|
||||
[alignment '(center top)])])
|
||||
(new button%
|
||||
[label (string-constant white-on-black-color-scheme)]
|
||||
[parent hp]
|
||||
[callback (λ (x y)
|
||||
(preferences:set 'framework:white-on-black? #t)
|
||||
(white-on-black))])
|
||||
(new button%
|
||||
[label (string-constant black-on-white-color-scheme)]
|
||||
[parent hp]
|
||||
[callback (λ (x y)
|
||||
(preferences:set 'framework:white-on-black? #f)
|
||||
(black-on-white))]))))))
|
||||
|
||||
|
||||
(update-choice (preferences:get 'framework:paren-color-scheme)))))))
|
||||
|
||||
(define (build-text-foreground-selection-panel parent pref-sym style-name example-text)
|
||||
(define hp (new horizontal-panel%
|
||||
(parent parent)
|
||||
|
|
@ -414,9 +419,10 @@
|
|||
(get-color-from-user
|
||||
(format (string-constant syntax-coloring-choose-color) example-text)
|
||||
(send color-button get-top-level-window)
|
||||
(preferences:get pref-sym))])
|
||||
(lookup-in-color-scheme pref-sym)
|
||||
'(alpha))])
|
||||
(when users-choice
|
||||
(preferences:set pref-sym users-choice)))))))
|
||||
(set-in-color-scheme pref-sym users-choice)))))))
|
||||
(define style (send (send e get-style-list) find-named-style style-name))
|
||||
|
||||
(send c set-line-count 1)
|
||||
|
|
@ -426,39 +432,46 @@
|
|||
(send e set-position 0))
|
||||
|
||||
(define (add-solid-color-config label parent pref-id)
|
||||
(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
|
||||
(new canvas%
|
||||
(parent hp)
|
||||
(paint-callback
|
||||
(λ (c dc)
|
||||
(draw (preferences:get pref-id)))))]
|
||||
[draw
|
||||
(λ (clr)
|
||||
(let ([dc (send canvas get-dc)])
|
||||
(let-values ([(w h) (send canvas get-client-size)])
|
||||
(send dc set-brush (send the-brush-list find-or-create-brush clr 'solid))
|
||||
(send dc set-pen (send the-pen-list find-or-create-pen clr 1 'solid))
|
||||
(send dc draw-rectangle 0 0 w h))))]
|
||||
[button
|
||||
(new button%
|
||||
(label (string-constant cs-change-color))
|
||||
(parent hp)
|
||||
(callback
|
||||
(λ (x y)
|
||||
(let ([color (get-color-from-user
|
||||
(string-constant choose-a-background-color)
|
||||
(send hp get-top-level-window)
|
||||
(preferences:get pref-id))])
|
||||
(when color
|
||||
(preferences:set pref-id color))))))])
|
||||
(preferences:add-callback
|
||||
pref-id
|
||||
(λ (p v) (draw v)))
|
||||
panel))
|
||||
|
||||
(define panel (new vertical-panel% (parent parent) (stretchable-height #f)))
|
||||
(define hp (new horizontal-panel% (parent panel) (stretchable-height #f)))
|
||||
(define msg (new message% (parent hp) (label label)))
|
||||
(define canvas
|
||||
(new canvas%
|
||||
(parent hp)
|
||||
(paint-callback
|
||||
(λ (c dc)
|
||||
(draw (lookup-in-color-scheme pref-id))))))
|
||||
(define (draw clr)
|
||||
(define dc (send canvas get-dc))
|
||||
(define-values (w h) (send canvas get-client-size))
|
||||
(send dc set-pen (send the-pen-list find-or-create-pen "black" 1 'transparent))
|
||||
(send dc set-brush (if (preferences:get 'framework:white-on-black?)
|
||||
"black"
|
||||
"white")
|
||||
'solid)
|
||||
(send dc draw-rectangle 0 0 w h)
|
||||
(send dc set-brush (send the-brush-list find-or-create-brush clr 'solid))
|
||||
(send dc draw-rectangle 0 0 w h))
|
||||
(define button
|
||||
(new button%
|
||||
(label (string-constant cs-change-color))
|
||||
(parent hp)
|
||||
(callback
|
||||
(λ (x y)
|
||||
(define color (get-color-from-user
|
||||
(string-constant choose-a-background-color)
|
||||
(send hp get-top-level-window)
|
||||
(lookup-in-color-scheme pref-id)
|
||||
'(alpha)))
|
||||
(when color
|
||||
(set-in-color-scheme pref-id color))))))
|
||||
(register-color-scheme-entry-change-callback
|
||||
pref-id
|
||||
(λ (v)
|
||||
;; the pref should be updated on the next event callback
|
||||
(queue-callback (λ () (send canvas refresh)))))
|
||||
panel)
|
||||
|
||||
;; add-to-preferences-panel : string (vertical-panel -> void) -> void
|
||||
(define (add-to-preferences-panel panel-name func)
|
||||
(preferences:add-panel
|
||||
|
|
@ -512,17 +525,19 @@
|
|||
(preferences:set-un/marshall
|
||||
pref-sym
|
||||
(λ (clr) (list (send clr red) (send clr green) (send clr blue) (send clr alpha)))
|
||||
(λ (lst)
|
||||
(match lst
|
||||
[(list (? byte? red) (? byte? green) (? byte? blue))
|
||||
;; old prefs-- before there were no alpha components to color% objects
|
||||
;; and so only r/g/b was saved.
|
||||
(make-object color% red green blue)]
|
||||
[(list (? byte? red) (? byte? green) (? byte? blue) (? (λ (x) (and (real? x) (<= 0 x 1))) α))
|
||||
(make-object color% red green blue α)]
|
||||
[else #f])))
|
||||
unmarshall-color)
|
||||
(void)))
|
||||
|
||||
(define (unmarshall-color lst)
|
||||
(match lst
|
||||
[(list (? byte? red) (? byte? green) (? byte? blue))
|
||||
;; old prefs-- before there were no alpha components to color% objects
|
||||
;; and so only r/g/b was saved.
|
||||
(make-object color% red green blue)]
|
||||
[(list (? byte? red) (? byte? green) (? byte? blue) (? (between/c 0 1) α))
|
||||
(make-object color% red green blue α)]
|
||||
[else #f]))
|
||||
|
||||
(define (to-color c)
|
||||
(cond
|
||||
[(is-a? c color%) c]
|
||||
|
|
@ -531,7 +546,8 @@
|
|||
(unless (and (= 0 (send m get-r))
|
||||
(= 0 (send m get-g))
|
||||
(= 0 (send m get-b)))
|
||||
(error 'register-color-scheme "expected a style delta with foreground-mult that is all zeros"))
|
||||
(error 'register-color-scheme
|
||||
"expected a style delta with foreground-mult that is all zeros"))
|
||||
(let ([add (send c get-foreground-add)])
|
||||
(make-object color%
|
||||
(send add get-r)
|
||||
|
|
@ -557,3 +573,459 @@
|
|||
(send old set-delta-foreground color)
|
||||
(preferences:set p old)])))
|
||||
color-scheme-colors))
|
||||
|
||||
|
||||
;
|
||||
;
|
||||
;
|
||||
;
|
||||
; ;;; ;;;
|
||||
; ;;; ;;;
|
||||
; ;;; ;;; ;;; ;;; ;;; ;; ;;;; ;;; ;;; ;; ;;;; ;;; ;; ;;; ;;;; ;;;;
|
||||
; ;;;;; ;;;;; ;;; ;;;;; ;;;;; ;;; ;; ;;;;; ;;;;;;; ;; ;;; ;;;;;;;;;;; ;; ;;; ;;; ;;
|
||||
; ;;; ;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;;
|
||||
; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;;; ;;; ;;; ;;; ;;;;;;; ;;; ;;; ;;; ;;;;;;; ;;;;
|
||||
; ;;; ;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;;
|
||||
; ;;;;; ;;;;; ;;; ;;;;; ;;; ;; ;;; ;;;;; ;;; ;;; ;;;;;; ;;; ;;; ;;; ;;;;;; ;; ;;;
|
||||
; ;;; ;;; ;;; ;;; ;;; ;;;; ;;; ;;; ;;; ;;;; ;;; ;;; ;;; ;;;; ;;;;
|
||||
;
|
||||
;
|
||||
;
|
||||
;
|
||||
|
||||
(define default-example
|
||||
(string-append
|
||||
"#lang racket ; draw a graph of cos\n"
|
||||
"(require plot) ; and deriv^3(cos)\n"
|
||||
"(define ((deriv f) x)\n"
|
||||
" (/ (- (f x) (f (- x 0.001))) 0.001))\n"
|
||||
"(define (thrice f) (lambda (x) (f (f (f x)))))\n"
|
||||
"(plot (list (function ((thrice deriv) sin) -5 5)\n"
|
||||
" (function cos -5 5 #:color 'blue)))\n"
|
||||
"\"an unclosed string is an error"))
|
||||
|
||||
(struct color-scheme (name button-label white-on-black-base? mapping example))
|
||||
(define black-on-white-color-scheme-name 'classic)
|
||||
(define white-on-black-color-scheme-name 'white-on-black)
|
||||
(define known-color-schemes
|
||||
;; note:first item in this list must be the black-on-white color scheme
|
||||
;; and the second must the white-on-black color scheme
|
||||
(list (color-scheme black-on-white-color-scheme-name
|
||||
(string-constant classic-color-scheme)
|
||||
#f (make-hash) default-example)
|
||||
(color-scheme white-on-black-color-scheme-name
|
||||
(string-constant white-on-black-color-scheme)
|
||||
#t (make-hash) default-example)))
|
||||
|
||||
(define color-change-callbacks (make-hash))
|
||||
|
||||
(define known-color-names (set))
|
||||
(define known-style-names (set))
|
||||
|
||||
(define-logger color-scheme)
|
||||
|
||||
(define (register-info-based-color-schemes)
|
||||
(log-color-scheme-info
|
||||
"color-names: ~a\nstyle-names:\n~a\n"
|
||||
(sort (set->list known-color-names) symbol<?)
|
||||
(sort (set->list known-style-names) symbol<?))
|
||||
(for ([dir (in-list (find-relevant-directories '(framework:color-schemes)))])
|
||||
(define info (get-info/full dir))
|
||||
(when info
|
||||
(define cs-info (info 'framework:color-schemes))
|
||||
(cond
|
||||
[(info-file-result-check? cs-info)
|
||||
(for ([one-scheme (in-list cs-info)])
|
||||
(define name (hash-ref one-scheme 'name
|
||||
(λ ()
|
||||
(define d (path->module-path dir))
|
||||
(if (path-string? d)
|
||||
(format "~a" d)
|
||||
(format "~s" d)))))
|
||||
(define white-on-black-base? (hash-ref one-scheme 'white-on-black-base? #f))
|
||||
(define mapping (hash-ref one-scheme 'colors '()))
|
||||
(define example (hash-ref one-scheme 'example default-example))
|
||||
(register-color-scheme (if (symbol? name)
|
||||
(dynamic-string-constant name)
|
||||
name)
|
||||
white-on-black-base?
|
||||
mapping
|
||||
example))]
|
||||
[else
|
||||
(when cs-info
|
||||
(log-color-scheme-warning
|
||||
"expected something matching:\n~a\nfor framework:color-schemes in ~a, got\n~a"
|
||||
(pretty-format (contract-name info-file-result-check?))
|
||||
dir
|
||||
(pretty-format cs-info)))]))))
|
||||
|
||||
|
||||
;; register-color-scheme : string boolean? (listof (cons/c symbol? (listof props)) -> void
|
||||
;; props = (or/c 'bold 'italic 'underline
|
||||
;;
|
||||
;; called based on the contents of info.rkt files
|
||||
(define (register-color-scheme scheme-name white-on-black-base? mapping example)
|
||||
(define (good-line? line)
|
||||
(or (set-member? known-color-names (car line))
|
||||
(set-member? known-style-names (car line))))
|
||||
(for ([x (in-list mapping)])
|
||||
(unless (good-line? x)
|
||||
(log-color-scheme-warning "unknown style/color name: ~s" x)))
|
||||
(set! known-color-schemes
|
||||
(append known-color-schemes
|
||||
(list
|
||||
(color-scheme
|
||||
(if (symbol? scheme-name)
|
||||
scheme-name
|
||||
(string->symbol scheme-name))
|
||||
(if (symbol? scheme-name)
|
||||
(dynamic-string-constant scheme-name)
|
||||
scheme-name)
|
||||
white-on-black-base?
|
||||
(make-hash
|
||||
(for/list ([line (in-list mapping)]
|
||||
#:when (good-line? line))
|
||||
(define name (car line))
|
||||
(cons name
|
||||
(cond
|
||||
[(set-member? known-color-names name)
|
||||
(props->color (cdr line))]
|
||||
[(set-member? known-style-names name)
|
||||
(props->style-delta (cdr line))]))))
|
||||
example)))))
|
||||
|
||||
(define valid-props?
|
||||
(listof (or/c 'bold 'italic 'underline
|
||||
(vector/c byte? byte? byte? #:flat? #t)
|
||||
(vector/c byte? byte? byte? (between/c 0.0 1.0) #:flat? #t))))
|
||||
|
||||
(define (valid-key-values? h)
|
||||
(for/or ([(k v) (in-hash h)])
|
||||
(cond
|
||||
[(equal? k 'name) (or (string? v) (symbol? v))]
|
||||
[(equal? k 'white-on-black-base?) (boolean? v)]
|
||||
[(equal? k 'colors) ((listof (cons/c symbol? valid-props?)) v)]
|
||||
[(equal? k 'example) (string? v)]
|
||||
[else
|
||||
;; don't care about other keys, as they'll be ignored
|
||||
#t])))
|
||||
|
||||
(define info-file-result-check?
|
||||
(listof (and/c hash?
|
||||
immutable?
|
||||
valid-key-values?)))
|
||||
|
||||
(define (props->color line)
|
||||
(or (for/or ([v (in-list line)])
|
||||
(and (vector? v)
|
||||
(vec->color v)))
|
||||
(vec->color #'(0 0 0))))
|
||||
|
||||
(define (props->style-delta line)
|
||||
(define sd (new style-delta%))
|
||||
(for ([prop (in-list line)])
|
||||
(match prop
|
||||
[`bold (send sd set-delta 'change-bold)]
|
||||
[`italic (send sd set-delta 'change-italic)]
|
||||
[`underline (send sd set-delta 'change-underline #t)]
|
||||
[else (send sd set-delta-foreground (vec->color prop))]))
|
||||
sd)
|
||||
|
||||
(define (vec->color v)
|
||||
(make-object color%
|
||||
(vector-ref v 0)
|
||||
(vector-ref v 1)
|
||||
(vector-ref v 2)
|
||||
(if (= (vector-length v) 4)
|
||||
(vector-ref v 3)
|
||||
1.0)))
|
||||
|
||||
;; returns the user's preferred color, wrt to the current color scheme
|
||||
(define (lookup-in-color-scheme color-name)
|
||||
(lookup-in-color-scheme/given-mapping
|
||||
color-name
|
||||
(preferences:get (color-scheme-entry-name->pref-name color-name))
|
||||
(get-current-color-scheme)))
|
||||
|
||||
(define (lookup-in-color-scheme/given-mapping color-name table a-color-scheme)
|
||||
(cond
|
||||
;; check if the user adjusted the color
|
||||
[(hash-ref table (color-scheme-name a-color-scheme) #f)
|
||||
=>
|
||||
values]
|
||||
;; check if the color scheme has that mapping
|
||||
[(hash-ref (color-scheme-mapping a-color-scheme)
|
||||
color-name
|
||||
#f)
|
||||
=> values]
|
||||
[else
|
||||
;; fall back to either the white-on-black or the black-on-white color scheme
|
||||
(define fallback-color-scheme
|
||||
(lookup-color-scheme
|
||||
(if (color-scheme-white-on-black-base? a-color-scheme)
|
||||
white-on-black-color-scheme-name
|
||||
black-on-white-color-scheme-name)))
|
||||
(hash-ref (color-scheme-mapping fallback-color-scheme)
|
||||
color-name)]))
|
||||
|
||||
;; set-color : symbol (or/c string? (is-a?/c color%) (is-a?/c style-delta%)) -> void
|
||||
(define (set-in-color-scheme color-name clr/sd)
|
||||
(define table (preferences:get (color-scheme-entry-name->pref-name color-name)))
|
||||
(define current-color-scheme (get-current-color-scheme))
|
||||
(define scheme-name (color-scheme-name current-color-scheme))
|
||||
(define new-table
|
||||
(cond
|
||||
[(set-member? known-style-names color-name)
|
||||
;; it would be good to be able to use hash-remove here when
|
||||
(hash-set table scheme-name clr/sd)]
|
||||
[else
|
||||
(define color (->color-object clr/sd))
|
||||
(define default
|
||||
(hash-ref (color-scheme-mapping current-color-scheme)
|
||||
color-name
|
||||
#f))
|
||||
(cond
|
||||
[(and default (same-color? color default))
|
||||
(hash-remove table scheme-name)]
|
||||
[else
|
||||
(hash-set table scheme-name color)])]))
|
||||
(preferences:set (color-scheme-entry-name->pref-name color-name) new-table))
|
||||
|
||||
(define (->color-object clr)
|
||||
(if (string? clr)
|
||||
(send the-color-database find-color clr)
|
||||
clr))
|
||||
|
||||
(define (same-color? c1 c2)
|
||||
(and (= (send c1 red) (send c2 red))
|
||||
(= (send c1 green) (send c2 green))
|
||||
(= (send c1 blue) (send c2 blue))
|
||||
(= (send c1 alpha) (send c2 alpha))))
|
||||
|
||||
(define (get-current-color-scheme)
|
||||
;; if pref not recognized, return white-on-black color scheme
|
||||
;; so that if some color scheme goes away, we have
|
||||
;; some reasonable backup plan (and, if it comes back
|
||||
;; we don't lose the prefs)
|
||||
(define pref-val (preferences:get 'framework:color-scheme))
|
||||
(define found-color-scheme (lookup-color-scheme pref-val))
|
||||
(cond
|
||||
[found-color-scheme found-color-scheme]
|
||||
[else (car known-color-schemes)]))
|
||||
|
||||
;; string -> (or/c #f color-scheme?)
|
||||
(define (lookup-color-scheme name)
|
||||
(for/or ([known-color-scheme (in-list known-color-schemes)])
|
||||
(and (equal? name (color-scheme-name known-color-scheme))
|
||||
known-color-scheme)))
|
||||
|
||||
(define (set-current-color-scheme name)
|
||||
(define color-scheme
|
||||
(or (for/or ([known-color-scheme (in-list known-color-schemes)])
|
||||
(and (equal? name (color-scheme-name known-color-scheme))
|
||||
known-color-scheme))
|
||||
(car known-color-schemes)))
|
||||
(unless (equal? (color-scheme-name color-scheme)
|
||||
(color-scheme-name (get-current-color-scheme)))
|
||||
(preferences:set 'framework:color-scheme (color-scheme-name color-scheme))
|
||||
(define old-wob (preferences:get 'framework:white-on-black?))
|
||||
(define new-wob (color-scheme-white-on-black-base? color-scheme))
|
||||
(unless (equal? old-wob new-wob)
|
||||
(preferences:set 'framework:white-on-black? new-wob)
|
||||
(if new-wob
|
||||
(white-on-black)
|
||||
(black-on-white)))
|
||||
(for ([(color-name fns) (in-hash color-change-callbacks)])
|
||||
(for ([fn/b (in-list fns)])
|
||||
(define fn (if (weak-box? fn/b) (weak-box-value fn/b) fn/b))
|
||||
(when fn
|
||||
(fn (lookup-in-color-scheme color-name)))))))
|
||||
|
||||
(define (get-available-color-schemes)
|
||||
(for/list ([(name a-color-scheme) (in-hash known-color-schemes)])
|
||||
name))
|
||||
|
||||
;; symbol (-> (or/c (is-a?/c style-delta%) (is-a?/c color%)) void) -> void
|
||||
(define (register-color-scheme-entry-change-callback color fn [weak? #f])
|
||||
(define wb/f (if weak? (make-weak-box fn) fn))
|
||||
;; so we know which callbacks to call when a color scheme change happens
|
||||
(hash-set! color-change-callbacks
|
||||
color
|
||||
(cons wb/f
|
||||
(remove-gones (hash-ref color-change-callbacks color '()))))
|
||||
;; so that individual color changes in a given scheme get callbacks
|
||||
(define remover
|
||||
(preferences:add-callback
|
||||
(color-scheme-entry-name->pref-name color)
|
||||
(λ (pref ht)
|
||||
(define fn
|
||||
(cond
|
||||
[(weak-box? wb/f)
|
||||
(define fn (weak-box-value wb/f))
|
||||
(unless fn (remover))
|
||||
fn]
|
||||
[else wb/f]))
|
||||
(when fn
|
||||
(fn (lookup-in-color-scheme/given-mapping
|
||||
color
|
||||
ht
|
||||
(get-current-color-scheme)))))))
|
||||
(void))
|
||||
|
||||
(define (remove-gones lst)
|
||||
(for/list ([x (in-list lst)]
|
||||
#:when (or (not (weak-box? x))
|
||||
(weak-box-value x)))
|
||||
x))
|
||||
|
||||
(define (known-color-scheme-name? n)
|
||||
(or (set-member? known-color-names n)
|
||||
(set-member? known-style-names n)))
|
||||
|
||||
(define (color-scheme-style-name? n)
|
||||
(set-member? known-style-names n))
|
||||
|
||||
(define (color-scheme-entry-name->pref-name sym)
|
||||
(string->symbol (format "color-scheme-entry:~a" sym)))
|
||||
|
||||
(define name->style-name (make-hash))
|
||||
|
||||
(define (add-color-scheme-entry name _b-o-w-color _w-o-b-color
|
||||
#:style [style-name #f]
|
||||
#:bold? [bold? #f]
|
||||
#:underline? [underline? #f]
|
||||
#:italic? [italic? #f]
|
||||
#:background [background #f])
|
||||
(define b-o-w-color (->color-object _b-o-w-color))
|
||||
(define w-o-b-color (->color-object _w-o-b-color))
|
||||
(cond
|
||||
[style-name
|
||||
(set! known-style-names (set-add known-style-names name))
|
||||
(hash-set! name->style-name name style-name)]
|
||||
[else
|
||||
(set! known-color-names (set-add known-color-names name))])
|
||||
(define (update-color scheme-name color)
|
||||
(hash-set! (color-scheme-mapping (lookup-color-scheme scheme-name))
|
||||
name
|
||||
(if style-name
|
||||
(make-style-delta color bold? underline? italic? #:background background)
|
||||
color)))
|
||||
(update-color white-on-black-color-scheme-name w-o-b-color)
|
||||
(update-color black-on-white-color-scheme-name b-o-w-color)
|
||||
(preferences:set-default (color-scheme-entry-name->pref-name name)
|
||||
(hash)
|
||||
(hash/c symbol?
|
||||
(if style-name
|
||||
(is-a?/c style-delta%)
|
||||
(is-a?/c color%))
|
||||
#:immutable #t))
|
||||
(preferences:set-un/marshall
|
||||
(color-scheme-entry-name->pref-name name)
|
||||
(λ (h)
|
||||
(for/hash ([(k v) (in-hash h)])
|
||||
(values k
|
||||
(if style-name
|
||||
(marshall-style-delta v)
|
||||
(vector (send v red) (send v green) (send v blue) (send v alpha))))))
|
||||
(λ (val)
|
||||
(cond
|
||||
[(and (list? val) (= (length val) (length style-delta-get/set)))
|
||||
;; old style prefs; check to see if this user
|
||||
;; was using the white on black or black on white and
|
||||
;; build the corresponding new pref
|
||||
(hash (if (preferences:get 'framework:white-on-black?)
|
||||
white-on-black-color-scheme-name
|
||||
black-on-white-color-scheme-name)
|
||||
(unmarshall-style-delta val))]
|
||||
[(unmarshall-color val)
|
||||
=>
|
||||
(λ (clr)
|
||||
;; old color prefs; as above
|
||||
(hash (if (preferences:get 'framework:white-on-black?)
|
||||
white-on-black-color-scheme-name
|
||||
black-on-white-color-scheme-name)
|
||||
clr))]
|
||||
[(hash? val)
|
||||
;; this may return a bogus hash, but the preferesnces system will check
|
||||
;; and revert this to the default pref in that case
|
||||
(for/hash ([(k v) (in-hash val)])
|
||||
(values
|
||||
k
|
||||
(if style-name
|
||||
(unmarshall-style-delta v)
|
||||
(and (vector? v)
|
||||
(= (vector-length v) 4)
|
||||
(make-object color%
|
||||
(vector-ref v 0) (vector-ref v 1)
|
||||
(vector-ref v 2) (vector-ref v 3))))))]
|
||||
[else #f])))
|
||||
|
||||
(when style-name
|
||||
(register-color-scheme-entry-change-callback
|
||||
name
|
||||
(λ (sd)
|
||||
(editor:set-standard-style-list-delta style-name sd)))
|
||||
(editor:set-standard-style-list-delta style-name (lookup-in-color-scheme name))))
|
||||
|
||||
(define (add-color-scheme-preferences-panel)
|
||||
(preferences:add-panel
|
||||
(list (string-constant preferences-colors)
|
||||
(string-constant color-schemes))
|
||||
(λ (parent)
|
||||
(define vp
|
||||
(new vertical-panel%
|
||||
[parent parent]
|
||||
[style '(auto-vscroll)]))
|
||||
(define buttons
|
||||
(for/list ([color-scheme (in-list known-color-schemes)])
|
||||
(define hp (new horizontal-panel%
|
||||
[parent vp]
|
||||
[alignment '(left top)]
|
||||
[stretchable-height #t]))
|
||||
(define t (new racket:text%))
|
||||
(define str (color-scheme-example color-scheme))
|
||||
(send t insert str)
|
||||
(define ec (new editor-canvas%
|
||||
[parent hp]
|
||||
[style '(auto-hscroll no-vscroll)]
|
||||
[editor t]))
|
||||
(send ec set-canvas-background
|
||||
(send the-color-database find-color
|
||||
(if (color-scheme-white-on-black-base? color-scheme)
|
||||
"black"
|
||||
"white")))
|
||||
(send t set-style-list (color-scheme->style-list color-scheme))
|
||||
(send ec set-line-count (+ 1 (for/sum ([c (in-string str)])
|
||||
(if (equal? c #\newline)
|
||||
1
|
||||
0))))
|
||||
(new button%
|
||||
[label (color-scheme-button-label color-scheme)]
|
||||
[parent hp]
|
||||
[callback (λ (x y)
|
||||
(set-current-color-scheme
|
||||
(color-scheme-name color-scheme)))])))
|
||||
(define wid (apply max (map (λ (x) (send x get-width)) buttons)))
|
||||
(for ([b (in-list buttons)])
|
||||
(send b min-width wid)))))
|
||||
|
||||
(define (color-scheme->style-list color-scheme)
|
||||
(define style-list (new style-list%))
|
||||
|
||||
(define standard-delta (make-object style-delta% 'change-normal))
|
||||
(send standard-delta set-delta 'change-family 'modern)
|
||||
(send standard-delta set-size-mult 0)
|
||||
(send standard-delta set-size-add (editor:get-current-preferred-font-size))
|
||||
(send style-list new-named-style "Standard"
|
||||
(send style-list find-or-create-style
|
||||
(send style-list basic-style)
|
||||
standard-delta))
|
||||
(for ([name (in-set known-style-names)])
|
||||
(define delta
|
||||
(lookup-in-color-scheme/given-mapping name (hash) color-scheme))
|
||||
(send style-list new-named-style
|
||||
(hash-ref name->style-name name)
|
||||
(send style-list find-or-create-style
|
||||
(send style-list find-named-style "Standard")
|
||||
delta)))
|
||||
style-list)
|
||||
|
|
|
|||
|
|
@ -678,7 +678,8 @@ added get-regions
|
|||
(define clear-old-locations void)
|
||||
|
||||
(define mismatch-color (make-object color% "PINK"))
|
||||
(define/private (get-match-color) (preferences:get 'framework:paren-match-color))
|
||||
(define/private (get-match-color)
|
||||
(color-prefs:lookup-in-color-scheme 'framework:paren-match-color))
|
||||
|
||||
|
||||
;; higlight : number number number (or/c color any)
|
||||
|
|
@ -1232,7 +1233,7 @@ added get-regions
|
|||
'low))))
|
||||
(cons (list 'basic-grey
|
||||
(string-constant paren-color-basic-grey)
|
||||
(vector (preferences:get 'framework:paren-match-color))
|
||||
(vector (color-prefs:lookup-in-color-scheme 'framework:paren-match-color))
|
||||
'high)
|
||||
parenthesis-color-table))
|
||||
|
||||
|
|
|
|||
|
|
@ -25,6 +25,8 @@
|
|||
|
||||
(application-preferences-handler (λ () (preferences:show-dialog)))
|
||||
|
||||
(preferences:set-default 'framework:color-scheme 'classic symbol?)
|
||||
|
||||
(preferences:set-default 'framework:column-guide-width
|
||||
'(#f 102)
|
||||
(list/c boolean? (and/c exact-integer? (>=/c 2))))
|
||||
|
|
@ -193,7 +195,7 @@
|
|||
(preferences:set-default 'framework:case-sensitive-search?
|
||||
#f
|
||||
boolean?)
|
||||
(color-prefs:set-default/color-scheme 'framework:basic-canvas-background "white" "black")
|
||||
(color-prefs:add-color-scheme-entry 'framework:basic-canvas-background "white" "black")
|
||||
|
||||
(preferences:set-default 'framework:special-meta-key #f boolean?)
|
||||
(preferences:add-callback 'framework:special-meta-key (λ (p v) (map-command-as-meta-key v)))
|
||||
|
|
@ -250,26 +252,26 @@
|
|||
(- (* 7/8 256) 1))])
|
||||
(define default-color (make-object color% 0 0 0 (- 1. (/ gray-level 255))))
|
||||
(define w-o-b-default-color (make-object color% 255 255 255 (/ 50 255)))
|
||||
(color-prefs:set-default/color-scheme 'framework:paren-match-color
|
||||
default-color
|
||||
w-o-b-default-color)
|
||||
(color-prefs:add-color-scheme-entry 'framework:paren-match-color
|
||||
default-color
|
||||
w-o-b-default-color)
|
||||
|
||||
;; when the preference is currently set to the old color,
|
||||
;; then just update it to the new one (if someone really
|
||||
;; wants the old default, they can still have a color that is
|
||||
;; off by one from the old default which should be ok)
|
||||
(define current-color (preferences:get 'framework:paren-match-color))
|
||||
(define current-color (color-prefs:lookup-in-color-scheme 'framework:paren-match-color))
|
||||
(cond
|
||||
[(and (= (send current-color red) gray-level)
|
||||
(= (send current-color green) gray-level)
|
||||
(= (send current-color blue) gray-level)
|
||||
(= (send current-color alpha) 1.0))
|
||||
(preferences:set 'framework:paren-match-color default-color)]
|
||||
(color-prefs:set-in-color-scheme 'framework:paren-match-color default-color)]
|
||||
[(and (= (send current-color red) 50)
|
||||
(= (send current-color green) 50)
|
||||
(= (send current-color blue) 50)
|
||||
(= (send current-color alpha) 1.0))
|
||||
(preferences:set 'framework:paren-match-color w-o-b-default-color)]))
|
||||
(color-prefs:set-in-color-scheme 'framework:paren-match-color w-o-b-default-color)]))
|
||||
|
||||
(preferences:set-default 'framework:recently-opened-files/pos
|
||||
null
|
||||
|
|
@ -494,34 +496,36 @@
|
|||
(preferences:set-default 'framework:file-dialogs 'std
|
||||
(λ (x) (and (memq x '(common std)) #t)))
|
||||
|
||||
(for-each (λ (line white-on-black-line)
|
||||
(let ([sym (car line)]
|
||||
[color (cadr line)]
|
||||
[white-on-black-color (cadr white-on-black-line)])
|
||||
(color-prefs:register-color-preference
|
||||
(racket:short-sym->pref-name sym)
|
||||
(racket:short-sym->style-name sym)
|
||||
color
|
||||
white-on-black-color)))
|
||||
(racket:get-color-prefs-table)
|
||||
(racket:get-white-on-black-color-prefs-table))
|
||||
(for ([line (in-list (racket:get-color-prefs-table))]
|
||||
[white-on-black-line (in-list (racket:get-white-on-black-color-prefs-table))])
|
||||
(define sym (car line))
|
||||
(define color (cadr line))
|
||||
(define white-on-black-color (cadr white-on-black-line))
|
||||
(color-prefs:add-color-scheme-entry (racket:short-sym->pref-name sym)
|
||||
#:style (racket:short-sym->style-name sym)
|
||||
color
|
||||
white-on-black-color))
|
||||
|
||||
(preferences:set-default 'framework:coloring-active #t boolean?)
|
||||
|
||||
(color-prefs:set-default/color-scheme 'framework:default-text-color "black" "white")
|
||||
(preferences:add-callback 'framework:basic-canvas-background
|
||||
(λ (p v)
|
||||
(editor:set-default-font-color
|
||||
(preferences:get 'framework:default-text-color)
|
||||
v)))
|
||||
(preferences:add-callback 'framework:default-text-color
|
||||
(λ (p v)
|
||||
(editor:set-default-font-color
|
||||
v
|
||||
(preferences:get 'framework:basic-canvas-background))))
|
||||
(editor:set-default-font-color (preferences:get 'framework:default-text-color)
|
||||
(preferences:get 'framework:basic-canvas-background))
|
||||
(color-prefs:add-color-scheme-entry 'framework:default-text-color "black" "white")
|
||||
(color-prefs:register-color-scheme-entry-change-callback
|
||||
'framework:basic-canvas-background
|
||||
(λ (v)
|
||||
(editor:set-default-font-color
|
||||
(color-prefs:lookup-in-color-scheme 'framework:default-text-color)
|
||||
v)))
|
||||
(color-prefs:register-color-scheme-entry-change-callback
|
||||
'framework:default-text-color
|
||||
(λ (v)
|
||||
(editor:set-default-font-color
|
||||
v
|
||||
(color-prefs:lookup-in-color-scheme 'framework:basic-canvas-background))))
|
||||
(editor:set-default-font-color
|
||||
(color-prefs:lookup-in-color-scheme 'framework:default-text-color)
|
||||
(color-prefs:lookup-in-color-scheme 'framework:basic-canvas-background))
|
||||
|
||||
(color-prefs:set-default/color-scheme 'framework:misspelled-text-color "black" "white")
|
||||
(color-prefs:add-color-scheme-entry 'framework:misspelled-text-color "black" "white")
|
||||
|
||||
(color-prefs:set-default/color-scheme 'framework:delegatee-overview-color
|
||||
"light blue"
|
||||
|
|
@ -545,11 +549,11 @@
|
|||
(send style get-delta delta)
|
||||
(send delta set-delta-foreground v)
|
||||
(send style set-delta delta))])
|
||||
(preferences:add-callback
|
||||
(color-prefs:register-color-scheme-entry-change-callback
|
||||
'framework:misspelled-text-color
|
||||
(λ (p v) (update-style-list v)))
|
||||
(λ (v) (update-style-list v)))
|
||||
(update-style-list
|
||||
(preferences:get 'framework:misspelled-text-color)))
|
||||
(color-prefs:lookup-in-color-scheme 'framework:misspelled-text-color)))
|
||||
|
||||
;; groups
|
||||
|
||||
|
|
|
|||
|
|
@ -429,7 +429,18 @@
|
|||
unmarshall-style-delta
|
||||
set-default/color-scheme
|
||||
white-on-black
|
||||
black-on-white))
|
||||
black-on-white
|
||||
|
||||
add-color-scheme-preferences-panel
|
||||
set-current-color-scheme
|
||||
get-current-color-scheme
|
||||
known-color-scheme-name?
|
||||
color-scheme-style-name?
|
||||
lookup-in-color-scheme
|
||||
set-in-color-scheme
|
||||
register-color-scheme-entry-change-callback
|
||||
add-color-scheme-entry
|
||||
register-info-based-color-schemes))
|
||||
|
||||
(define-signature racket-class^
|
||||
(text<%>
|
||||
|
|
|
|||
|
|
@ -1332,9 +1332,9 @@
|
|||
(abbreviate-cons-as-list #t)
|
||||
(allow-sharing? #f)
|
||||
(reader-module '(lib "htdp-beginner-abbr-reader.ss" "lang"))
|
||||
(stepper:supported #t)
|
||||
(stepper:supported #t)
|
||||
(stepper:enable-let-lifting #t)
|
||||
(stepper:show-lambdas-as-lambdas #f)))
|
||||
(stepper:show-lambdas-as-lambdas #f)))
|
||||
|
||||
(add-htdp-language
|
||||
(instantiate htdp-language% ()
|
||||
|
|
@ -1352,25 +1352,24 @@
|
|||
(allow-sharing? #f)
|
||||
(accept-quasiquote? #f)
|
||||
(reader-module '(lib "htdp-beginner-reader.ss" "lang"))
|
||||
(stepper:supported #t)
|
||||
(stepper:supported #t)
|
||||
(stepper:enable-let-lifting #t)
|
||||
(stepper:show-lambdas-as-lambdas #f))))
|
||||
(stepper:show-lambdas-as-lambdas #f))))
|
||||
|
||||
(define test-coverage-on-style-name "plt:htdp:test-coverage-on")
|
||||
(define test-coverage-off-style-name "plt:htdp:test-coverage-off")
|
||||
(define test-coverage-on-style-pref (string->symbol test-coverage-on-style-name))
|
||||
(define test-coverage-off-style-pref (string->symbol test-coverage-off-style-name))
|
||||
|
||||
(color-prefs:register-color-preference test-coverage-on-style-pref
|
||||
test-coverage-on-style-name
|
||||
(send the-color-database find-color "black")
|
||||
(send the-color-database find-color "white"))
|
||||
(color-prefs:register-color-preference test-coverage-off-style-pref
|
||||
test-coverage-off-style-name
|
||||
(send the-color-database find-color "orange")
|
||||
(send the-color-database find-color "indianred")
|
||||
#:background
|
||||
(send the-color-database find-color "black"))
|
||||
(color-prefs:add-color-scheme-entry test-coverage-on-style-pref
|
||||
#:style test-coverage-on-style-name
|
||||
"black"
|
||||
"white")
|
||||
(color-prefs:add-color-scheme-entry test-coverage-off-style-pref
|
||||
#:style test-coverage-off-style-name
|
||||
"orange"
|
||||
"indianred"
|
||||
#:background "black")
|
||||
(color-prefs:add-to-preferences-panel
|
||||
"HtDP Languages"
|
||||
(λ (parent)
|
||||
|
|
@ -1382,27 +1381,4 @@
|
|||
test-coverage-off-style-pref
|
||||
test-coverage-off-style-name
|
||||
(string-constant test-coverage-off)
|
||||
#:background? #t)))
|
||||
|
||||
(define (update-sds white-on-black?)
|
||||
(define sl (editor:get-standard-style-list))
|
||||
(define on-s (send sl find-named-style test-coverage-on-style-name))
|
||||
(define off-s (send sl find-named-style test-coverage-off-style-name))
|
||||
(define on-sd (make-object style-delta%))
|
||||
(define off-sd (make-object style-delta%))
|
||||
(send on-s get-delta on-sd)
|
||||
(send off-s get-delta off-sd)
|
||||
(cond
|
||||
[white-on-black?
|
||||
(send on-sd set-delta-foreground "white")
|
||||
(send off-sd set-delta-foreground "indianred")
|
||||
(send off-sd set-delta-background "black")]
|
||||
[else
|
||||
(send on-sd set-delta-foreground "black")
|
||||
(send off-sd set-delta-foreground "orange")
|
||||
(send off-sd set-delta-background "black")])
|
||||
(preferences:set test-coverage-on-style-pref on-sd)
|
||||
(preferences:set test-coverage-off-style-pref off-sd))
|
||||
|
||||
(preferences:add-callback 'framework:white-on-black?
|
||||
(λ (p v) (update-sds v)))))
|
||||
#:background? #t)))))
|
||||
|
|
|
|||
|
|
@ -548,13 +548,15 @@ please adhere to these guidelines:
|
|||
(hide-column-width-guide "Hide Column Width Guide for Files with ~a Columns")
|
||||
(show-column-width-guide "Show Column Width Guide at ~a Columns") ;; filled with a number > 2
|
||||
(limit-interactions-size "Limit interactions size")
|
||||
(background-color "Background Color")
|
||||
(background-color "Background") ;; this is in the color section already, so shorten the name a little
|
||||
(default-text-color "Default text") ;; used for configuring colors, but doesn't need the word "color"
|
||||
(choose-a-background-color "Please choose a background color")
|
||||
(revert-to-defaults "Revert to Defaults")
|
||||
(undo-changes "Undo Changes and Close") ;; used in the preferences dialog to undo preference changes
|
||||
|
||||
(black-on-white-color-scheme "Black on White") ;; these two appear in the color preferences dialog on butttons
|
||||
(color-schemes "Color Schemes") ;; the label in the preferences dialog for the color scheme panel
|
||||
(classic-color-scheme "Classic") ;; formerly called 'black on white'
|
||||
(modern-color-scheme "Modern") ;; an attempt to be more color-blind friendly
|
||||
(white-on-black-color-scheme "White on Black") ;; clicking the buttons changes the color schemes to some defaults that've been set up.
|
||||
|
||||
(add-spacing-between-lines "Add one pixel of extra space between lines")
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user