misc improvements to the white on black view in drscheme (also added explicit buttons that switch to a default set of colors and also flips a preferences flag for more coarse grained control)
svn: r5892 original commit: d688a1f9e3d6cf001852404c7fafc55ffaace710
This commit is contained in:
Robby Findler
parent
97fcdf04a7
commit
d73e8448d5
|
|
@ -1245,6 +1245,22 @@
|
|||
"@flink scheme:short-sym->pref-name"
|
||||
"and"
|
||||
"@flink scheme:short-sym->style-name %"
|
||||
"."
|
||||
""
|
||||
"See also"
|
||||
"@flink scheme:get-white-on-black-color-prefs-table %"
|
||||
".")
|
||||
|
||||
(scheme:get-white-on-black-color-prefs-table
|
||||
(-> (listof (list/c 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 when the user chooses the white-on-black mode in the"
|
||||
"preferences dialog."
|
||||
""
|
||||
"See also"
|
||||
"@flink scheme:get-color-prefs-table %"
|
||||
".")
|
||||
|
||||
(scheme:short-sym->pref-name
|
||||
|
|
@ -1364,9 +1380,29 @@
|
|||
(xyz)
|
||||
"Extracts the z component of \\var{xyz}.")
|
||||
|
||||
(color-prefs:set-default/color-scheme
|
||||
(-> symbol?
|
||||
(or/c (is-a?/c color%) string?)
|
||||
(or/c (is-a?/c color%) string?)
|
||||
void?)
|
||||
(pref-sym black-on-white-color white-on-black-color)
|
||||
"Registers a preference whose value will be updated"
|
||||
"when the user clicks on one of the color scheme default"
|
||||
"settings in the preferences dialog."
|
||||
""
|
||||
"Also calls "
|
||||
"@flink preferences:set-default"
|
||||
"and"
|
||||
"@flink preferences:set-un/marshall"
|
||||
"with appropriate arguments to register the preference.")
|
||||
|
||||
(color-prefs:register-color-pref
|
||||
(symbol? string? (or/c (is-a?/c color%) (is-a?/c style-delta%)) . -> . void?)
|
||||
(pref-name style-name color/sd)
|
||||
(opt->
|
||||
(symbol? string? (or/c (is-a?/c color%) (is-a?/c style-delta%)))
|
||||
((or/c string? (is-a?/c color%) false/c))
|
||||
void?)
|
||||
((pref-name style-name color/sd)
|
||||
((white-on-black-color #f)))
|
||||
"This function registers a color preference and initializes the"
|
||||
"style list returned from"
|
||||
"@flink editor:get-standard-style-list %"
|
||||
|
|
@ -1387,7 +1423,13 @@
|
|||
"Finally, it adds calls"
|
||||
"@flink preferences:add-callback "
|
||||
"to set a callback for \\var{pref-name} that"
|
||||
"updates the style list when the preference changes.")
|
||||
"updates the style list when the preference changes."
|
||||
""
|
||||
"If \\var{white-on-black-color} is not \\scheme|#f|, then the color of the"
|
||||
"\\var{color/sd} argument is used in combination with \\var{white-on-black-color}"
|
||||
"to register this preference with"
|
||||
"@flink color-prefs:set-default/color-scheme %"
|
||||
".")
|
||||
|
||||
(color-prefs:add-background-preferences-panel
|
||||
(-> void?)
|
||||
|
|
|
|||
|
|
@ -136,11 +136,24 @@
|
|||
|
||||
|
||||
(define clickback-delta (make-object style-delta% 'change-underline #t))
|
||||
(define white-on-black-clickback-delta (make-object style-delta% 'change-underline #t))
|
||||
(send clickback-delta set-delta-foreground "BLUE")
|
||||
(define (get-clickback-delta) clickback-delta)
|
||||
(send white-on-black-clickback-delta set-delta-foreground "lightblue")
|
||||
(define get-clickback-delta
|
||||
(opt-lambda ([white-on-black? #f])
|
||||
(if white-on-black?
|
||||
white-on-black-clickback-delta
|
||||
clickback-delta)))
|
||||
|
||||
(define clicked-clickback-delta (make-object style-delta%))
|
||||
(define white-on-black-clicked-clickback-delta (make-object style-delta%))
|
||||
(send clicked-clickback-delta set-delta-background "BLACK")
|
||||
(define (get-clicked-clickback-delta) clicked-clickback-delta)
|
||||
(send white-on-black-clicked-clickback-delta set-delta-background "white")
|
||||
(define get-clicked-clickback-delta
|
||||
(opt-lambda ([white-on-black? #f])
|
||||
(if white-on-black?
|
||||
white-on-black-clicked-clickback-delta
|
||||
clicked-clickback-delta)))
|
||||
|
||||
(define next-untitled-name
|
||||
(let ([n 1])
|
||||
|
|
@ -475,27 +488,41 @@
|
|||
"caller's responsibility to avoid the dialog if not needed.")
|
||||
|
||||
(gui-utils:get-clicked-clickback-delta
|
||||
(-> (is-a?/c style-delta%))
|
||||
()
|
||||
(opt->
|
||||
()
|
||||
(boolean?)
|
||||
(is-a?/c style-delta%))
|
||||
(()
|
||||
((white-on-black? #f)))
|
||||
"This delta is designed for use with"
|
||||
"@link text set-clickback %"
|
||||
". Use it as one of the \\iscmclass{style-delta} argument to"
|
||||
"@link text set-clickback %"
|
||||
"."
|
||||
""
|
||||
"If \\var{white-on-black?} is true, the function returns"
|
||||
"a delta suitable for use on a black background."
|
||||
""
|
||||
"See also"
|
||||
"@flink gui-utils:get-clickback-delta %"
|
||||
".")
|
||||
|
||||
(gui-utils:get-clickback-delta
|
||||
(-> (is-a?/c style-delta%))
|
||||
()
|
||||
(opt->
|
||||
()
|
||||
(boolean?)
|
||||
(is-a?/c style-delta%))
|
||||
(()
|
||||
((white-on-black? #f)))
|
||||
"This delta is designed for use with"
|
||||
"@link text set-clickback %"
|
||||
". Use the result of this function as the style"
|
||||
"for the region"
|
||||
"text where the clickback is set."
|
||||
""
|
||||
"If \\var{white-on-black?} is true, the function returns"
|
||||
"a delta suitable for use on a black background."
|
||||
""
|
||||
"See also"
|
||||
"@flink gui-utils:get-clicked-clickback-delta %"
|
||||
".")))
|
||||
|
|
|
|||
|
|
@ -228,7 +228,9 @@ the state transitions / contracts are:
|
|||
(begin
|
||||
(v p value)
|
||||
(cons callback (loop (cdr callbacks))))
|
||||
(loop (cdr callbacks))))]
|
||||
(begin
|
||||
(printf "lost a ~s callback\n" p)
|
||||
(loop (cdr callbacks)))))]
|
||||
[else
|
||||
(cb p value)
|
||||
(cons callback (loop (cdr callbacks)))]))]))])
|
||||
|
|
@ -383,7 +385,12 @@ the state transitions / contracts are:
|
|||
"\\scmindex{exn:unknown-preference}\\rawscm{exn:unknown-preference}"
|
||||
"if the preference's default has not been set.")
|
||||
(preferences:add-callback
|
||||
(opt-> (symbol? (symbol? any/c . -> . any/c))
|
||||
(opt-> (symbol?
|
||||
|
||||
;; important that this arg only has a flat contract
|
||||
;; so that no wrapper is created, so that
|
||||
;; the weak box stuff works ...
|
||||
(λ (x) (and (procedure? x) (procedure-arity-includes? x 2))))
|
||||
(boolean?)
|
||||
(-> void?))
|
||||
((p f)
|
||||
|
|
|
|||
|
|
@ -207,7 +207,20 @@
|
|||
(build-text-foreground-selection-panel vp
|
||||
'framework:default-text-color
|
||||
(editor:get-default-color-style-name)
|
||||
(string-constant default-text-color))))))
|
||||
(string-constant default-text-color))
|
||||
|
||||
(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) (white-on-black))])
|
||||
(new button%
|
||||
[label (string-constant black-on-white-color-scheme)]
|
||||
[parent hp]
|
||||
[callback (λ (x y) (black-on-white))]))))))
|
||||
|
||||
|
||||
(define (build-text-foreground-selection-panel parent pref-sym style-name example-text)
|
||||
(define hp (new horizontal-panel%
|
||||
|
|
@ -293,17 +306,76 @@
|
|||
panel))))
|
||||
|
||||
;; see docs
|
||||
(define (register-color-pref pref-name style-name color/sd)
|
||||
(let ([sd (cond
|
||||
[(is-a? color/sd style-delta%)
|
||||
color/sd]
|
||||
[else
|
||||
(let ([sd (new style-delta%)])
|
||||
(send sd set-delta-foreground color/sd)
|
||||
sd)])])
|
||||
(preferences:set-default pref-name sd (λ (x) (is-a? x style-delta%))))
|
||||
(preferences:set-un/marshall pref-name marshall-style unmarshall-style)
|
||||
(preferences:add-callback pref-name
|
||||
(λ (sym v)
|
||||
(editor:set-standard-style-list-delta style-name v)))
|
||||
(editor:set-standard-style-list-delta style-name (preferences:get pref-name))))
|
||||
(define register-color-pref
|
||||
(opt-lambda (pref-name style-name color/sd [white-on-black-color #f])
|
||||
(let ([sd (cond
|
||||
[(is-a? color/sd style-delta%)
|
||||
color/sd]
|
||||
[else
|
||||
(let ([sd (new style-delta%)])
|
||||
(send sd set-delta-foreground color/sd)
|
||||
sd)])])
|
||||
(preferences:set-default pref-name sd (λ (x) (is-a? x style-delta%)))
|
||||
(when white-on-black-color
|
||||
(set! color-scheme-colors
|
||||
(cons (list pref-name
|
||||
color/sd
|
||||
(to-color white-on-black-color))
|
||||
color-scheme-colors)))
|
||||
(preferences:set-un/marshall pref-name marshall-style unmarshall-style)
|
||||
(preferences:add-callback pref-name
|
||||
(λ (sym v)
|
||||
(editor:set-standard-style-list-delta style-name v)))
|
||||
(editor:set-standard-style-list-delta style-name (preferences:get pref-name)))))
|
||||
|
||||
(define color-scheme-colors '())
|
||||
|
||||
(define (set-default/color-scheme pref-sym black-on-white white-on-black)
|
||||
(let ([bw-c (to-color black-on-white)]
|
||||
[wb-c (to-color white-on-black)])
|
||||
(set! color-scheme-colors
|
||||
(cons (list pref-sym
|
||||
(to-color black-on-white)
|
||||
(to-color white-on-black))
|
||||
color-scheme-colors))
|
||||
|
||||
(preferences:set-default pref-sym bw-c (λ (x) (is-a? x color%)))
|
||||
(preferences:set-un/marshall
|
||||
pref-sym
|
||||
(λ (clr) (list (send clr red) (send clr green) (send clr blue)))
|
||||
(λ (lst) (and (pair? lst)
|
||||
(pair? (cdr lst))
|
||||
(pair? (cddr lst))
|
||||
(null? (cdddr lst))
|
||||
(make-object color% (car lst) (cadr lst) (caddr lst)))))
|
||||
(void)))
|
||||
|
||||
(define (to-color c)
|
||||
(cond
|
||||
[(is-a? c color%) c]
|
||||
[(is-a? c style-delta%)
|
||||
(send c get-delta-foreground)]
|
||||
[(string? c)
|
||||
(or (send the-color-database find-color c)
|
||||
(error 'register-color-scheme
|
||||
"did not find color ~s in the-color-database"
|
||||
c))]))
|
||||
|
||||
(define (black-on-white)
|
||||
(preferences:set 'framework:white-on-black? #f)
|
||||
(do-colorization cadr))
|
||||
(define (white-on-black)
|
||||
(preferences:set 'framework:white-on-black? #t)
|
||||
(do-colorization caddr))
|
||||
(define (do-colorization sel)
|
||||
(for-each (λ (l)
|
||||
(let* ([p (car l)]
|
||||
[color (sel l)]
|
||||
[old (preferences:get p)])
|
||||
(cond
|
||||
[(is-a? old color%)
|
||||
(preferences:set p color)]
|
||||
[(is-a? old style-delta%)
|
||||
(send old set-delta-foreground color)
|
||||
(preferences:set p old)])))
|
||||
color-scheme-colors)))
|
||||
|
|
|
|||
|
|
@ -34,7 +34,7 @@
|
|||
[-pasteboard% pasteboard%]
|
||||
[-text% text%]))
|
||||
|
||||
(init-depend mred^ framework:text^)
|
||||
(init-depend mred^ framework:text^ framework:canvas^)
|
||||
|
||||
(define (reorder-menus frame)
|
||||
(define items (send (send frame get-menu-bar) get-items))
|
||||
|
|
@ -1414,7 +1414,7 @@
|
|||
delegate-moved))
|
||||
|
||||
(define delegatee-editor-canvas%
|
||||
(class editor-canvas%
|
||||
(class (canvas:color-mixin canvas:basic%)
|
||||
(init-field delegate-frame)
|
||||
(inherit get-editor get-dc)
|
||||
|
||||
|
|
@ -1525,9 +1525,14 @@
|
|||
(let ([old-pen (send dc get-pen)]
|
||||
[old-brush (send dc get-brush)])
|
||||
(send dc set-pen
|
||||
(send the-pen-list find-or-create-pen "light blue" 1 'solid))
|
||||
(send the-pen-list find-or-create-pen
|
||||
(preferences:get 'framework:delegatee-overview-color)
|
||||
1
|
||||
'solid))
|
||||
(send dc set-brush
|
||||
(send the-brush-list find-or-create-brush "light blue" 'solid))
|
||||
(send the-brush-list find-or-create-brush
|
||||
(preferences:get 'framework:delegatee-overview-color)
|
||||
'solid))
|
||||
(let-values ([(x y w h) (get-rectangle start-para end-para)])
|
||||
(when x
|
||||
(send dc draw-rectangle
|
||||
|
|
|
|||
|
|
@ -15,293 +15,284 @@
|
|||
(export framework:main^)
|
||||
(init-depend framework:preferences^ framework:exit^ framework:editor^
|
||||
framework:color-prefs^ framework:scheme^)
|
||||
|
||||
|
||||
(preferences:low-level-put-preferences preferences:put-preferences/gui)
|
||||
|
||||
(application-preferences-handler (λ () (preferences:show-dialog)))
|
||||
|
||||
(preferences:set-default 'framework:square-bracket:cond/offset
|
||||
'(("case-lambda" 0)
|
||||
("cond" 0)
|
||||
("field" 0)
|
||||
("provide/contract" 0)
|
||||
("new" 1)
|
||||
("case" 1)
|
||||
("syntax-case" 2)
|
||||
("syntax-case*" 3))
|
||||
(λ (x) (and (list? x) (andmap (λ (x) (and (pair? x)
|
||||
(string? (car x))
|
||||
(pair? (cdr x))
|
||||
(number? (cadr x))
|
||||
(null? (cddr x))))
|
||||
x))))
|
||||
|
||||
(preferences:set-default 'framework:square-bracket:letrec
|
||||
'("let"
|
||||
"let*" "let-values" "let*-values"
|
||||
"let-syntax" "let-struct" "let-syntaxes"
|
||||
"letrec"
|
||||
"letrec-syntaxes" "letrec-syntaxes+values" "letrec-values"
|
||||
"parameterize"
|
||||
"with-syntax")
|
||||
(λ (x) (and (list? x) (andmap string? x))))
|
||||
|
||||
(preferences:set-default 'framework:case-sensitive-search?
|
||||
#f
|
||||
boolean?)
|
||||
(preferences:set-default 'framework:basic-canvas-background
|
||||
(send the-color-database find-color "white")
|
||||
(λ (x) (is-a? x color%)))
|
||||
(preferences:set-un/marshall
|
||||
'framework:basic-canvas-background
|
||||
(λ (clr) (list (send clr red) (send clr green) (send clr blue)))
|
||||
(λ (lst) (and (pair? lst)
|
||||
(pair? (cdr lst))
|
||||
(pair? (cddr lst))
|
||||
(null? (cdddr lst))
|
||||
(make-object color% (car lst) (cadr lst) (caddr lst)))))
|
||||
|
||||
(preferences:set-default 'framework:special-option-key #f boolean?)
|
||||
(preferences:add-callback 'framework:special-option-key (λ (p v) (special-option-key v)))
|
||||
(special-option-key (preferences:get 'framework:special-option-key))
|
||||
|
||||
(preferences:set-default 'framework:fraction-snip-style 'mixed (λ (x) (memq x '(mixed improper))))
|
||||
|
||||
(preferences:set-default 'framework:standard-style-list:font-name
|
||||
(get-family-builtin-face 'modern)
|
||||
string?)
|
||||
|
||||
(preferences:set-default
|
||||
'framework:standard-style-list:font-size
|
||||
(let* ([txt (make-object text%)]
|
||||
[stl (send txt get-style-list)]
|
||||
[bcs (send stl basic-style)])
|
||||
(send bcs get-size))
|
||||
(λ (x) (and (number? x) (exact? x) (integer? x) (positive? x))))
|
||||
|
||||
(preferences:set-default
|
||||
'framework:standard-style-list:smoothing
|
||||
'default
|
||||
(λ (x)
|
||||
(memq x '(unsmoothed partly-smoothed smoothed default))))
|
||||
|
||||
(editor:set-standard-style-list-pref-callbacks)
|
||||
|
||||
(preferences:set-default 'framework:paren-match-color
|
||||
(let ([gray-level
|
||||
;; old gray-level 192
|
||||
(if (eq? (system-type) 'windows)
|
||||
(* 3/4 256)
|
||||
(- (* 7/8 256) 1))])
|
||||
(make-object color% gray-level gray-level gray-level))
|
||||
(λ (x) (is-a? x color%)))
|
||||
|
||||
(preferences:set-un/marshall
|
||||
'framework:paren-match-color
|
||||
(λ (c) (list (send c red) (send c green) (send c blue)))
|
||||
(λ (l) (make-object color% (car l) (cadr l) (caddr l))))
|
||||
|
||||
(preferences:set-default 'framework:recently-opened-files/pos
|
||||
null
|
||||
(λ (x) (and (list? x)
|
||||
(andmap
|
||||
(λ (x)
|
||||
(and (list? x)
|
||||
(= 3 (length x))
|
||||
(path? (car x))
|
||||
(number? (cadr x))
|
||||
(number? (caddr x))))
|
||||
x))))
|
||||
|
||||
(preferences:set-un/marshall
|
||||
'framework:recently-opened-files/pos
|
||||
(λ (l) (map (λ (ele) (cons (path->bytes (car ele)) (cdr ele))) l))
|
||||
(λ (l)
|
||||
(let/ec k
|
||||
(unless (list? l)
|
||||
(k '()))
|
||||
(map (λ (x)
|
||||
(unless (and (list? x)
|
||||
(= 3 (length x))
|
||||
(bytes? (car x))
|
||||
(number? (cadr x))
|
||||
(number? (caddr x)))
|
||||
(k '()))
|
||||
(cons (bytes->path (car x)) (cdr x)))
|
||||
l))))
|
||||
|
||||
(preferences:set-default 'framework:last-directory
|
||||
(find-system-path 'doc-dir)
|
||||
(λ (x) (or (not x) path-string?)))
|
||||
|
||||
(preferences:set-un/marshall 'framework:last-directory
|
||||
(λ (x) (and (path? x) (path->bytes x)))
|
||||
(λ (x)
|
||||
(and (bytes? x)
|
||||
(bytes->path x))))
|
||||
|
||||
(preferences:set-default 'framework:recent-max-count
|
||||
50
|
||||
(λ (x) (and (number? x)
|
||||
(x . > . 0)
|
||||
(integer? x))))
|
||||
(preferences:add-callback
|
||||
'framework:recent-max-count
|
||||
(λ (p v)
|
||||
(handler:size-recently-opened-files v)))
|
||||
|
||||
(preferences:set-default 'framework:last-url-string "" string?)
|
||||
(preferences:set-default 'framework:recently-opened-sort-by 'age
|
||||
(λ (x) (or (eq? x 'age) (eq? x 'name))))
|
||||
(preferences:set-default 'framework:recent-items-window-w 400 number?)
|
||||
(preferences:set-default 'framework:recent-items-window-h 600 number?)
|
||||
(preferences:set-default 'framework:open-here? #f boolean?)
|
||||
(preferences:set-default 'framework:show-delegate? #f boolean?)
|
||||
(preferences:set-default 'framework:search-using-dialog? #t boolean?)
|
||||
(preferences:set-default 'framework:windows-mdi #f boolean?)
|
||||
(preferences:set-default 'framework:menu-bindings #t boolean?)
|
||||
(preferences:set-default 'framework:verify-change-format #f boolean?)
|
||||
(preferences:set-default 'framework:auto-set-wrap? #t boolean?)
|
||||
(preferences:set-default 'framework:display-line-numbers #t boolean?)
|
||||
(preferences:set-default 'framework:show-status-line #t boolean?)
|
||||
(preferences:set-default 'framework:col-offsets #f boolean?)
|
||||
|
||||
(preferences:set-default
|
||||
'framework:print-output-mode
|
||||
'standard
|
||||
(λ (x) (or (eq? x 'standard) (eq? x 'postscript))))
|
||||
|
||||
(preferences:set-default 'framework:highlight-parens #t boolean?)
|
||||
(preferences:set-default 'framework:fixup-parens #t boolean?)
|
||||
(preferences:set-default 'framework:fixup-open-parens #t boolean?)
|
||||
(preferences:set-default 'framework:paren-match #t boolean?)
|
||||
(let ([hash-table (make-hash-table)])
|
||||
(for-each (λ (x)
|
||||
(hash-table-put! hash-table x 'define))
|
||||
'())
|
||||
(for-each (λ (x)
|
||||
(hash-table-put! hash-table x 'begin))
|
||||
'(case-lambda
|
||||
match-lambda match-lambda*
|
||||
cond
|
||||
delay
|
||||
unit compound-unit compound-unit/sig
|
||||
public private override
|
||||
inherit sequence))
|
||||
(for-each (λ (x)
|
||||
(hash-table-put! hash-table x 'lambda))
|
||||
'(
|
||||
cases
|
||||
instantiate super-instantiate
|
||||
syntax/loc quasisyntax/loc
|
||||
|
||||
|
||||
λ lambda let let* letrec recur
|
||||
lambda/kw
|
||||
letrec-values
|
||||
with-syntax
|
||||
with-continuation-mark
|
||||
module
|
||||
match match-let match-let* match-letrec
|
||||
let/cc let/ec letcc catch
|
||||
let-syntax letrec-syntax fluid-let-syntax letrec-syntaxes+values
|
||||
|
||||
kernel-syntax-case
|
||||
syntax-case syntax-case* syntax-rules syntax-id-rules
|
||||
let-signature fluid-let
|
||||
let-struct let-macro let-values let*-values
|
||||
case when unless
|
||||
let-enumerate
|
||||
class class* class-asi class-asi* class*/names
|
||||
class100 class100* class100-asi class100-asi* class100*/names
|
||||
rec
|
||||
make-object mixin
|
||||
define-some do opt-lambda
|
||||
send* with-method
|
||||
define-record
|
||||
local catch shared
|
||||
unit/sig unit/lang
|
||||
with-handlers
|
||||
interface
|
||||
parameterize
|
||||
call-with-input-file call-with-input-file* with-input-from-file
|
||||
with-input-from-port call-with-output-file
|
||||
with-output-to-file with-output-to-port))
|
||||
(preferences:set-default
|
||||
'framework:tabify
|
||||
(list hash-table #rx"^begin" #rx"^def" #f)
|
||||
(λ (x)
|
||||
(and (list? x)
|
||||
(= (length x) 4)
|
||||
(hash-table? (car x))
|
||||
(andmap (λ (x) (or (regexp? x) (not x))) (cdr x)))))
|
||||
(preferences:set-un/marshall
|
||||
'framework:tabify
|
||||
(λ (t) (cons (hash-table-map (car t) list)
|
||||
(cdr t)))
|
||||
(λ (l)
|
||||
(and (list? l)
|
||||
(= (length l) 4)
|
||||
(andmap (λ (x) (or (regexp? x) (not x)))
|
||||
(cdr l))
|
||||
(andmap (λ (x) (and (list? x)
|
||||
(= 2 (length x))
|
||||
(andmap symbol? x)))
|
||||
(car l))
|
||||
(let ([h (make-hash-table)])
|
||||
(for-each (λ (x) (apply hash-table-put! h x)) (car l))
|
||||
(cons h (cdr l)))))))
|
||||
|
||||
|
||||
(preferences:set-default 'framework:autosave-delay 300 number?)
|
||||
(preferences:set-default 'framework:autosaving-on? #t boolean?)
|
||||
(preferences:set-default 'framework:backup-files? #t boolean?)
|
||||
(preferences:set-default 'framework:verify-exit #t boolean?)
|
||||
(preferences:set-default 'framework:delete-forward? #t boolean?)
|
||||
(preferences:set-default 'framework:show-periods-in-dirlist #f boolean?)
|
||||
(preferences:set-default 'framework:file-dialogs 'std
|
||||
(λ (x) (and (memq x '(common std)) #t)))
|
||||
|
||||
;; scheme prefs
|
||||
|
||||
(for-each (λ (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?)
|
||||
|
||||
(preferences:set-default 'framework:default-text-color
|
||||
(send the-color-database find-color "Black")
|
||||
(λ (x) (is-a? x color%)))
|
||||
|
||||
(preferences:set-un/marshall 'framework:default-text-color
|
||||
(λ (c) (list (send c red) (send c green) (send c blue)))
|
||||
(λ (lst)
|
||||
(make-object color% (car lst) (cadr lst) (caddr lst))))
|
||||
(preferences:add-callback 'framework:default-text-color
|
||||
(λ (p v)
|
||||
(editor:set-default-font-color v)))
|
||||
(editor:set-default-font-color (preferences:get 'framework:default-text-color))
|
||||
|
||||
;; groups
|
||||
|
||||
(preferences:set-default 'framework:exit-when-no-frames #t boolean?)
|
||||
(preferences:set 'framework:exit-when-no-frames #t)
|
||||
|
||||
(exit:insert-can?-callback
|
||||
(λ ()
|
||||
(send (group:get-the-frame-group) can-close-all?)))
|
||||
|
||||
(exit:insert-on-callback
|
||||
(λ ()
|
||||
(send (group:get-the-frame-group) on-close-all)))
|
||||
|
||||
;; reset these -- they are only for the test suite.
|
||||
;; they do not need to be set across starting up and shutting down
|
||||
;; the application.
|
||||
;(preferences:set 'framework:file-dialogs 'std)
|
||||
|
||||
(void))
|
||||
(preferences:set-default 'framework:square-bracket:cond/offset
|
||||
'(("case-lambda" 0)
|
||||
("cond" 0)
|
||||
("field" 0)
|
||||
("provide/contract" 0)
|
||||
("new" 1)
|
||||
("case" 1)
|
||||
("syntax-case" 2)
|
||||
("syntax-case*" 3))
|
||||
(λ (x) (and (list? x) (andmap (λ (x) (and (pair? x)
|
||||
(string? (car x))
|
||||
(pair? (cdr x))
|
||||
(number? (cadr x))
|
||||
(null? (cddr x))))
|
||||
x))))
|
||||
(preferences:set-default 'framework:white-on-black? #f boolean?)
|
||||
|
||||
(preferences:set-default 'framework:square-bracket:letrec
|
||||
'("let"
|
||||
"let*" "let-values" "let*-values"
|
||||
"let-syntax" "let-struct" "let-syntaxes"
|
||||
"letrec"
|
||||
"letrec-syntaxes" "letrec-syntaxes+values" "letrec-values"
|
||||
"parameterize"
|
||||
"with-syntax")
|
||||
(λ (x) (and (list? x) (andmap string? x))))
|
||||
|
||||
(preferences:set-default 'framework:case-sensitive-search?
|
||||
#f
|
||||
boolean?)
|
||||
(color-prefs:set-default/color-scheme 'framework:basic-canvas-background "white" "black")
|
||||
|
||||
(preferences:set-default 'framework:special-option-key #f boolean?)
|
||||
(preferences:add-callback 'framework:special-option-key (λ (p v) (special-option-key v)))
|
||||
(special-option-key (preferences:get 'framework:special-option-key))
|
||||
|
||||
(preferences:set-default 'framework:fraction-snip-style 'mixed (λ (x) (memq x '(mixed improper))))
|
||||
|
||||
(preferences:set-default 'framework:standard-style-list:font-name
|
||||
(get-family-builtin-face 'modern)
|
||||
string?)
|
||||
|
||||
(preferences:set-default
|
||||
'framework:standard-style-list:font-size
|
||||
(let* ([txt (make-object text%)]
|
||||
[stl (send txt get-style-list)]
|
||||
[bcs (send stl basic-style)])
|
||||
(send bcs get-size))
|
||||
(λ (x) (and (number? x) (exact? x) (integer? x) (positive? x))))
|
||||
|
||||
(preferences:set-default
|
||||
'framework:standard-style-list:smoothing
|
||||
'default
|
||||
(λ (x)
|
||||
(memq x '(unsmoothed partly-smoothed smoothed default))))
|
||||
|
||||
(editor:set-standard-style-list-pref-callbacks)
|
||||
|
||||
(color-prefs:set-default/color-scheme
|
||||
'framework:paren-match-color
|
||||
(let ([gray-level
|
||||
;; old gray-level 192
|
||||
(if (eq? (system-type) 'windows)
|
||||
(* 3/4 256)
|
||||
(- (* 7/8 256) 1))])
|
||||
(make-object color% gray-level gray-level gray-level))
|
||||
(make-object color% 50 50 50))
|
||||
|
||||
(preferences:set-default 'framework:recently-opened-files/pos
|
||||
null
|
||||
(λ (x) (and (list? x)
|
||||
(andmap
|
||||
(λ (x)
|
||||
(and (list? x)
|
||||
(= 3 (length x))
|
||||
(path? (car x))
|
||||
(number? (cadr x))
|
||||
(number? (caddr x))))
|
||||
x))))
|
||||
|
||||
(preferences:set-un/marshall
|
||||
'framework:recently-opened-files/pos
|
||||
(λ (l) (map (λ (ele) (cons (path->bytes (car ele)) (cdr ele))) l))
|
||||
(λ (l)
|
||||
(let/ec k
|
||||
(unless (list? l)
|
||||
(k '()))
|
||||
(map (λ (x)
|
||||
(unless (and (list? x)
|
||||
(= 3 (length x))
|
||||
(bytes? (car x))
|
||||
(number? (cadr x))
|
||||
(number? (caddr x)))
|
||||
(k '()))
|
||||
(cons (bytes->path (car x)) (cdr x)))
|
||||
l))))
|
||||
|
||||
(preferences:set-default 'framework:last-directory
|
||||
(find-system-path 'doc-dir)
|
||||
(λ (x) (or (not x) path-string?)))
|
||||
|
||||
(preferences:set-un/marshall 'framework:last-directory
|
||||
(λ (x) (and (path? x) (path->bytes x)))
|
||||
(λ (x)
|
||||
(and (bytes? x)
|
||||
(bytes->path x))))
|
||||
|
||||
(preferences:set-default 'framework:recent-max-count
|
||||
50
|
||||
(λ (x) (and (number? x)
|
||||
(x . > . 0)
|
||||
(integer? x))))
|
||||
(preferences:add-callback
|
||||
'framework:recent-max-count
|
||||
(λ (p v)
|
||||
(handler:size-recently-opened-files v)))
|
||||
|
||||
(preferences:set-default 'framework:last-url-string "" string?)
|
||||
(preferences:set-default 'framework:recently-opened-sort-by 'age
|
||||
(λ (x) (or (eq? x 'age) (eq? x 'name))))
|
||||
(preferences:set-default 'framework:recent-items-window-w 400 number?)
|
||||
(preferences:set-default 'framework:recent-items-window-h 600 number?)
|
||||
(preferences:set-default 'framework:open-here? #f boolean?)
|
||||
(preferences:set-default 'framework:show-delegate? #f boolean?)
|
||||
(preferences:set-default 'framework:search-using-dialog? #t boolean?)
|
||||
(preferences:set-default 'framework:windows-mdi #f boolean?)
|
||||
(preferences:set-default 'framework:menu-bindings #t boolean?)
|
||||
(preferences:set-default 'framework:verify-change-format #f boolean?)
|
||||
(preferences:set-default 'framework:auto-set-wrap? #t boolean?)
|
||||
(preferences:set-default 'framework:display-line-numbers #t boolean?)
|
||||
(preferences:set-default 'framework:show-status-line #t boolean?)
|
||||
(preferences:set-default 'framework:col-offsets #f boolean?)
|
||||
|
||||
(preferences:set-default
|
||||
'framework:print-output-mode
|
||||
'standard
|
||||
(λ (x) (or (eq? x 'standard) (eq? x 'postscript))))
|
||||
|
||||
(preferences:set-default 'framework:highlight-parens #t boolean?)
|
||||
(preferences:set-default 'framework:fixup-parens #t boolean?)
|
||||
(preferences:set-default 'framework:fixup-open-parens #t boolean?)
|
||||
(preferences:set-default 'framework:paren-match #t boolean?)
|
||||
(let ([hash-table (make-hash-table)])
|
||||
(for-each (λ (x)
|
||||
(hash-table-put! hash-table x 'define))
|
||||
'())
|
||||
(for-each (λ (x)
|
||||
(hash-table-put! hash-table x 'begin))
|
||||
'(case-lambda
|
||||
match-lambda match-lambda*
|
||||
cond
|
||||
delay
|
||||
unit compound-unit compound-unit/sig
|
||||
public private override
|
||||
inherit sequence))
|
||||
(for-each (λ (x)
|
||||
(hash-table-put! hash-table x 'lambda))
|
||||
'(
|
||||
cases
|
||||
instantiate super-instantiate
|
||||
syntax/loc quasisyntax/loc
|
||||
|
||||
|
||||
λ lambda let let* letrec recur
|
||||
lambda/kw
|
||||
letrec-values
|
||||
with-syntax
|
||||
with-continuation-mark
|
||||
module
|
||||
match match-let match-let* match-letrec
|
||||
let/cc let/ec letcc catch
|
||||
let-syntax letrec-syntax fluid-let-syntax letrec-syntaxes+values
|
||||
|
||||
kernel-syntax-case
|
||||
syntax-case syntax-case* syntax-rules syntax-id-rules
|
||||
let-signature fluid-let
|
||||
let-struct let-macro let-values let*-values
|
||||
case when unless
|
||||
let-enumerate
|
||||
class class* class-asi class-asi* class*/names
|
||||
class100 class100* class100-asi class100-asi* class100*/names
|
||||
rec
|
||||
make-object mixin
|
||||
define-some do opt-lambda
|
||||
send* with-method
|
||||
define-record
|
||||
local catch shared
|
||||
unit/sig unit/lang
|
||||
with-handlers
|
||||
interface
|
||||
parameterize
|
||||
call-with-input-file call-with-input-file* with-input-from-file
|
||||
with-input-from-port call-with-output-file
|
||||
with-output-to-file with-output-to-port))
|
||||
(preferences:set-default
|
||||
'framework:tabify
|
||||
(list hash-table #rx"^begin" #rx"^def" #f)
|
||||
(λ (x)
|
||||
(and (list? x)
|
||||
(= (length x) 4)
|
||||
(hash-table? (car x))
|
||||
(andmap (λ (x) (or (regexp? x) (not x))) (cdr x)))))
|
||||
(preferences:set-un/marshall
|
||||
'framework:tabify
|
||||
(λ (t) (cons (hash-table-map (car t) list)
|
||||
(cdr t)))
|
||||
(λ (l)
|
||||
(and (list? l)
|
||||
(= (length l) 4)
|
||||
(andmap (λ (x) (or (regexp? x) (not x)))
|
||||
(cdr l))
|
||||
(andmap (λ (x) (and (list? x)
|
||||
(= 2 (length x))
|
||||
(andmap symbol? x)))
|
||||
(car l))
|
||||
(let ([h (make-hash-table)])
|
||||
(for-each (λ (x) (apply hash-table-put! h x)) (car l))
|
||||
(cons h (cdr l)))))))
|
||||
|
||||
|
||||
(preferences:set-default 'framework:autosave-delay 300 number?)
|
||||
(preferences:set-default 'framework:autosaving-on? #t boolean?)
|
||||
(preferences:set-default 'framework:backup-files? #t boolean?)
|
||||
(preferences:set-default 'framework:verify-exit #t boolean?)
|
||||
(preferences:set-default 'framework:delete-forward? #t boolean?)
|
||||
(preferences:set-default 'framework:show-periods-in-dirlist #f boolean?)
|
||||
(preferences:set-default 'framework:file-dialogs 'std
|
||||
(λ (x) (and (memq x '(common std)) #t)))
|
||||
|
||||
;; scheme prefs
|
||||
|
||||
(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-pref (scheme:short-sym->pref-name sym)
|
||||
(scheme:short-sym->style-name sym)
|
||||
color
|
||||
white-on-black-color)))
|
||||
(scheme:get-color-prefs-table)
|
||||
(scheme:get-white-on-black-color-prefs-table))
|
||||
(preferences:set-default 'framework:coloring-active #t boolean?)
|
||||
|
||||
(color-prefs:set-default/color-scheme 'framework:default-text-color "black" "white")
|
||||
(preferences:add-callback 'framework:default-text-color
|
||||
(λ (p v)
|
||||
(editor:set-default-font-color v)))
|
||||
(editor:set-default-font-color (preferences:get 'framework:default-text-color))
|
||||
|
||||
(color-prefs:set-default/color-scheme 'framework:delegatee-overview-color
|
||||
"light blue"
|
||||
(make-object color% 62 67 155))
|
||||
|
||||
|
||||
;; groups
|
||||
|
||||
(preferences:set-default 'framework:exit-when-no-frames #t boolean?)
|
||||
(preferences:set 'framework:exit-when-no-frames #t)
|
||||
|
||||
(exit:insert-can?-callback
|
||||
(λ ()
|
||||
(send (group:get-the-frame-group) can-close-all?)))
|
||||
|
||||
(exit:insert-on-callback
|
||||
(λ ()
|
||||
(send (group:get-the-frame-group) on-close-all)))
|
||||
|
||||
;; reset these -- they are only for the test suite.
|
||||
;; they do not need to be set across starting up and shutting down
|
||||
;; the application.
|
||||
;(preferences:set 'framework:file-dialogs 'std)
|
||||
|
||||
;; setup the color scheme stuff
|
||||
|
||||
|
||||
(void))
|
||||
|
|
|
|||
|
|
@ -267,18 +267,40 @@
|
|||
;;; ;;; ;;; ;;; ;;; ;; ; ;; ;;; ; ;;; ;;; ;; ;; ;;;
|
||||
|
||||
|
||||
(define color-prefs-table
|
||||
(let ([constant-green (make-object color% 41 128 38)]
|
||||
[symbol-blue (make-object color% 38 38 128)])
|
||||
`((symbol ,symbol-blue ,(string-constant scheme-mode-color-symbol))
|
||||
(keyword ,symbol-blue ,(string-constant scheme-mode-color-keyword))
|
||||
(comment ,(make-object color% 194 116 31) ,(string-constant scheme-mode-color-comment))
|
||||
(string ,constant-green ,(string-constant scheme-mode-color-string))
|
||||
(constant ,constant-green ,(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 color-prefs-table
|
||||
(let ([constant-green (make-object color% 41 128 38)]
|
||||
[symbol-blue (make-object color% 38 38 128)])
|
||||
`((symbol ,symbol-blue ,(string-constant scheme-mode-color-symbol))
|
||||
(keyword ,symbol-blue ,(string-constant scheme-mode-color-keyword))
|
||||
(comment ,(make-object color% 194 116 31) ,(string-constant scheme-mode-color-comment))
|
||||
(string ,constant-green ,(string-constant scheme-mode-color-string))
|
||||
(constant ,constant-green ,(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 white-on-black-color-prefs-table
|
||||
(let* ([sym/kwd (make-object color% 102 102 255)]
|
||||
[new-entries
|
||||
`((symbol ,sym/kwd)
|
||||
(keyword ,sym/kwd)
|
||||
(comment ,(make-object color% 249 148 40))
|
||||
(string ,(make-object color% 51 174 51))
|
||||
(constant ,(make-object color% 60 194 57))
|
||||
(parenthesis ,(make-object color% 151 69 43))
|
||||
(other ,(make-object color% "white")))])
|
||||
(map
|
||||
(λ (line)
|
||||
(let ([new (assoc (car line) new-entries)])
|
||||
(if new
|
||||
(list* (car line)
|
||||
(cadr new)
|
||||
(cddr line))
|
||||
line)))
|
||||
color-prefs-table)))
|
||||
|
||||
(define (get-color-prefs-table) color-prefs-table)
|
||||
(define (get-white-on-black-color-prefs-table) white-on-black-color-prefs-table)
|
||||
|
||||
(define (short-sym->pref-name sym) (string->symbol (short-sym->style-name sym)))
|
||||
(define sn-hash (make-hash-table))
|
||||
|
|
|
|||
|
|
@ -369,7 +369,8 @@
|
|||
build-color-selection-panel
|
||||
add-background-preferences-panel
|
||||
marshall-style
|
||||
unmarshall-style))
|
||||
unmarshall-style
|
||||
set-default/color-scheme))
|
||||
|
||||
(define-signature scheme-class^
|
||||
(text<%>
|
||||
|
|
@ -393,6 +394,7 @@
|
|||
add-coloring-preferences-panel
|
||||
|
||||
get-color-prefs-table
|
||||
get-white-on-black-color-prefs-table
|
||||
short-sym->pref-name
|
||||
short-sym->style-name
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user