color-prefs.rkt
1 #lang racket/unit 2 (require racket/class 3 racket/gui/base 4 string-constants 5 racket/match 6 racket/contract/base 7 racket/set 8 setup/getinfo 9 setup/collects 10 string-constants 11 racket/pretty 12 "../preferences.rkt" 13 "sig.rkt" 14 "srcloc-panel.rkt") 15 16 (import [prefix preferences: framework:preferences^] 17 [prefix editor: framework:editor^] 18 [prefix canvas: framework:canvas^] 19 [prefix racket: framework:racket^] 20 [prefix color: framework:color^]) 21 (export framework:color-prefs^) 22 (init-depend framework:editor^) 23 24 (define standard-style-list-text% (editor:standard-style-list-mixin text%)) 25 26 ;; build-color-selection-panel : (is-a?/c area-container<%>) symbol string string -> void 27 ;; constructs a panel containg controls to configure the preferences panel. 28 (define (build-color-selection-panel parent pref-sym style-name example-text 29 #:background? [background? #f]) 30 (define (get-from-pref-sym) 31 (if (set-member? known-style-names pref-sym) 32 (lookup-in-color-scheme pref-sym) 33 (preferences:get pref-sym))) 34 (define (set-via-pref-sym delta) 35 (if (set-member? known-style-names pref-sym) 36 (set-in-color-scheme pref-sym delta) 37 (preferences:set pref-sym delta))) 38 (define (add-pref-sym-callback f) 39 (if (set-member? known-style-names pref-sym) 40 (register-color-scheme-entry-change-callback pref-sym f) 41 (preferences:add-callback pref-sym (λ (p sd) (f sd))))) 42 (define (update-style-delta func) 43 (let ([working-delta (new style-delta%)]) 44 (send working-delta copy (get-from-pref-sym)) 45 (func working-delta) 46 (set-via-pref-sym working-delta))) 47 (define hp (new-horizontal-panel% 48 [parent parent] 49 [style '(border)] 50 [alignment '(center top)] 51 [stretchable-height #f])) 52 53 (define e (new (class standard-style-list-text% 54 (inherit change-style get-style-list) 55 (define/augment (after-insert pos offset) 56 (inner (void) after-insert pos offset) 57 (let ([style (send (get-style-list) 58 find-named-style 59 style-name)]) 60 (change-style style pos (+ pos offset) #f))) 61 (super-new)))) 62 (define c (new canvas:color% 63 [parent hp] 64 [min-width 150] 65 [editor e] 66 [stretchable-height #t] 67 [style '(hide-hscroll hide-vscroll)])) 68 69 (define (make-check name on off) 70 (let* ([c (λ (check command) 71 (if (send check get-value) 72 (update-style-delta on) 73 (update-style-delta off)))] 74 [check (new check-box% 75 [label name] 76 [parent hp] 77 [callback c])]) 78 check)) 79 80 (define slant-check 81 (make-check (string-constant cs-italic) 82 (λ (delta) 83 (send delta set-style-on 'italic) 84 (send delta set-style-off 'base)) 85 (λ (delta) 86 (send delta set-style-on 'normal) 87 (send delta set-style-off 'base)))) 88 (define bold-check 89 (make-check (string-constant cs-bold) 90 (λ (delta) 91 (send delta set-weight-on 'bold) 92 (send delta set-weight-off 'base)) 93 (λ (delta) 94 (send delta set-weight-on 'normal) 95 (send delta set-weight-off 'base)))) 96 (define underline-check 97 (make-check (string-constant cs-underline) 98 (λ (delta) 99 (send delta set-underlined-on #t) 100 (send delta set-underlined-off #f)) 101 (λ (delta) 102 (send delta set-underlined-off #f) 103 (send delta set-underlined-on #f)))) 104 105 (define smoothing-options 106 '(default 107 partly-smoothed 108 smoothed 109 unsmoothed)) 110 (define smoothing-option-strings 111 (list (string-constant cs-smoothing-default) 112 (string-constant cs-smoothing-partial) 113 (string-constant cs-smoothing-full) 114 (string-constant cs-smoothing-none))) 115 116 (define (smoothing->index s) 117 (let loop ([i 0] 118 [l smoothing-options]) 119 (cond 120 [(null? l) 121 ;; if it is something strange or it is 'base, we go with 'default (which is 0) 122 0] 123 [else 124 (if (eq? (car l) s) 125 i 126 (loop (+ i 1) 127 (cdr l)))]))) 128 129 (define smoothing-menu 130 (new choice% 131 [label #f] 132 [parent hp] 133 [choices smoothing-option-strings] 134 [callback 135 (λ (c e) 136 (update-style-delta 137 (λ (delta) 138 (send delta set-smoothing-on 139 (list-ref smoothing-options 140 (send c get-selection))))))])) 141 142 (define fore/back-panel 143 (and background? 144 (new vertical-pane% 145 [parent hp] 146 [stretchable-width #f] 147 [stretchable-height #f]))) 148 149 (define foreground-color-button 150 (and (>= (get-display-depth) 8) 151 (new button% 152 [label (if background? 153 (string-constant cs-foreground-color) 154 (string-constant cs-change-color))] 155 [parent (if background? 156 fore/back-panel 157 hp)] 158 [callback 159 (λ (color-button evt) 160 (define pref (get-from-pref-sym)) 161 (define orig-add (send pref get-foreground-add)) 162 (define orig-mult (send pref get-foreground-mult)) 163 (define (avg x y z) (/ (+ x y z) 3)) 164 (define (pin-between lo x hi) (min (max lo x) hi)) 165 (define orig-α 166 (- 1 (pin-between 0 167 (avg (send orig-mult get-r) 168 (send orig-mult get-g) 169 (send orig-mult get-b)) 170 1))) 171 (define (to-byte v) (pin-between 0 (inexact->exact (round v)) 255)) 172 (define color 173 (make-object color% 174 (to-byte (- 255 (/ (- 255 (send orig-add get-r)) orig-α))) 175 (to-byte (- 255 (/ (- 255 (send orig-add get-g)) orig-α))) 176 (to-byte (- 255 (/ (- 255 (send orig-add get-b)) orig-α))) 177 orig-α)) 178 (define users-choice 179 (get-color-from-user 180 (format (string-constant syntax-coloring-choose-color) example-text) 181 (send color-button get-top-level-window) 182 color 183 '(alpha))) 184 (when users-choice 185 (update-style-delta 186 (λ (delta) 187 (define new-α (send users-choice alpha)) 188 (define α*users-choice 189 (make-object color% 190 (to-byte (- 255 (* (- 255 (send users-choice red)) new-α))) 191 (to-byte (- 255 (* (- 255 (send users-choice green)) new-α))) 192 (to-byte (- 255 (* (- 255 (send users-choice blue)) new-α))))) 193 (send delta set-delta-foreground α*users-choice) 194 (define new-mult (send delta get-foreground-mult)) 195 (send new-mult set (- 1 new-α) (- 1 new-α) (- 1 new-α))))))]))) 196 197 (define background-color-button 198 (and (>= (get-display-depth) 8) 199 background? 200 (new button% 201 [label (string-constant cs-background-color)] 202 [parent (if background? 203 fore/back-panel 204 hp)] 205 [callback 206 (λ (color-button evt) 207 (let* ([add (send (get-from-pref-sym) get-background-add)] 208 [color (make-object color% 209 (send add get-r) 210 (send add get-g) 211 (send add get-b))] 212 [users-choice 213 (get-color-from-user 214 (format (string-constant syntax-coloring-choose-color) example-text) 215 (send color-button get-top-level-window) 216 color 217 '(alpha))]) 218 (when users-choice 219 (update-style-delta 220 (λ (delta) 221 (send delta set-delta-background users-choice))))))]))) 222 223 (define style (send (send e get-style-list) find-named-style style-name)) 224 225 (send c set-line-count 1) 226 (send c allow-tab-exit #t) 227 228 (send e insert example-text) 229 (send e set-position 0) 230 231 (send slant-check set-value (or (eq? (send style get-style) 'slant) 232 (eq? (send style get-style) 'italic))) 233 (send bold-check set-value (eq? (send style get-weight) 'bold)) 234 (send underline-check set-value (send style get-underlined)) 235 (send smoothing-menu set-selection (smoothing->index (send style get-smoothing))) 236 237 (send hp reflow-container) 238 (when (> (send c get-height) 50) 239 (send c set-line-count #f) 240 (send c min-height 50) 241 (send c stretchable-height #f)) 242 243 (add-pref-sym-callback 244 (λ (sd) 245 (send slant-check set-value (or (equal? (send style get-style) 'slant) 246 (equal? (send style get-style) 'italic))) 247 (send bold-check set-value (equal? (send sd get-weight-on) 'bold)) 248 (send underline-check set-value (send sd get-underlined-on)) 249 (send smoothing-menu set-selection (smoothing->index (send sd get-smoothing-on))))) 250 (void)) 251 252 (define (add/mult-set m v) 253 (send m set (car v) (cadr v) (caddr v))) 254 255 (define (add/mult-get m) 256 (let ([b1 (box 0)] 257 [b2 (box 0)] 258 [b3 (box 0)]) 259 (send m get b1 b2 b3) 260 (map unbox (list b1 b2 b3)))) 261 262 (define style-delta-get/set 263 (let ([lo3n (λ (x) (and (list? x) (= (length x) 3) (andmap number? x)))]) 264 (list (list (λ (x) (send x get-alignment-off)) 265 (λ (x v) (send x set-alignment-off v)) 266 (λ (x) (memq x '(base top center bottom)))) 267 268 (list (λ (x) (send x get-alignment-on)) 269 (λ (x v) (send x set-alignment-on v)) 270 (λ (x) (memq x '(base top center bottom)))) 271 272 (list (λ (x) (add/mult-get (send x get-background-add))) 273 (λ (x v) (add/mult-set (send x get-background-add) v)) 274 lo3n) 275 276 (list (λ (x) (add/mult-get (send x get-background-mult))) 277 (λ (x v) (add/mult-set (send x get-background-mult) v)) 278 lo3n) 279 280 (list (λ (x) (send x get-face)) 281 (λ (x v) (send x set-face v)) 282 (λ (x) (or (string? x) (not x)))) 283 284 (list (λ (x) (send x get-family)) 285 (λ (x v) (send x set-family v)) 286 (λ (x) (memq x '(base default decorative roman script swiss modern symbol system)))) 287 288 (list (λ (x) (add/mult-get (send x get-foreground-add))) 289 (λ (x v) (add/mult-set (send x get-foreground-add) v)) 290 lo3n) 291 292 (list (λ (x) (add/mult-get (send x get-foreground-mult))) 293 (λ (x v) (add/mult-set (send x get-foreground-mult) v)) 294 lo3n) 295 296 (list (λ (x) (send x get-size-add)) 297 (λ (x v) (send x set-size-add v)) 298 (λ (x) (and (integer? x) (exact? x) (<= 0 x 255)))) 299 300 (list (λ (x) (send x get-size-mult)) 301 (λ (x v) (send x set-size-mult v)) 302 (λ (x) (and (number? x) (real? x)))) 303 304 (list (λ (x) (send x get-style-off)) 305 (λ (x v) (send x set-style-off v)) 306 (λ (x) (memq x '(base normal italic slant)))) 307 308 (list (λ (x) (send x get-style-on)) 309 (λ (x v) (send x set-style-on v)) 310 (λ (x) (memq x '(base normal italic slant)))) 311 312 (list (λ (x) (send x get-underlined-off)) 313 (λ (x v) (send x set-underlined-off v)) 314 boolean?) 315 316 (list (λ (x) (send x get-underlined-on)) 317 (λ (x v) (send x set-underlined-on v)) 318 boolean?) 319 320 (list (λ (x) (send x get-weight-off)) 321 (λ (x v) (send x set-weight-off v)) 322 (λ (x) (memq x '(base normal bold light)))) 323 324 (list (λ (x) (send x get-weight-on)) 325 (λ (x v) (send x set-weight-on v)) 326 (λ (x) (memq x '(base normal bold light))))))) 327 328 (define (marshall-style-delta style) 329 (map (λ (fs) ((car fs) style)) style-delta-get/set)) 330 331 (define (unmarshall-style-delta info) 332 (let ([style (make-object style-delta%)]) 333 334 (when (list? info) 335 (let loop ([style-delta-get/set style-delta-get/set] 336 [info info]) 337 (cond 338 [(null? info) (void)] 339 [(null? style-delta-get/set) (void)] 340 [else (let ([v (car info)] 341 [fs (car style-delta-get/set)]) 342 (when ((list-ref fs 2) v) 343 ((list-ref fs 1) style v)) 344 (loop (cdr style-delta-get/set) 345 (cdr info)))]))) 346 347 style)) 348 349 (define (make-style-delta color bold underline? italic? #:background [background #f]) 350 (define sd (make-object style-delta%)) 351 (send sd set-delta-foreground color) 352 (cond 353 [(equal? bold 'base) 354 (send sd set-weight-on 'base) 355 (send sd set-weight-off 'base)] 356 [bold 357 (send sd set-weight-on 'bold) 358 (send sd set-weight-off 'base)] 359 [else 360 (send sd set-weight-on 'base) 361 (send sd set-weight-off 'bold)]) 362 (send sd set-underlined-on underline?) 363 (send sd set-underlined-off (not underline?)) 364 (cond 365 [italic? 366 (send sd set-style-on 'italic) 367 (send sd set-style-off 'base)] 368 [else 369 (send sd set-style-on 'base) 370 (send sd set-style-off 'italic)]) 371 (when background 372 (send sd set-delta-background background)) 373 sd) 374 375 (define (add-background-preferences-panel) 376 (preferences:add-panel 377 (list (string-constant preferences-colors) 378 (string-constant background-color)) 379 (λ (parent) 380 (let ([vp (new-vertical-panel% (parent parent) (alignment '(left top)))]) 381 (add-solid-color-config (string-constant background-color) 382 vp 383 'framework:basic-canvas-background) 384 (add-solid-color-config (string-constant basic-gray-paren-match-color) 385 vp 386 'framework:paren-match-color) 387 (build-text-foreground-selection-panel vp 388 'framework:default-text-color 389 (editor:get-default-color-style-name) 390 (string-constant default-text-color)) 391 392 (build-text-foreground-selection-panel vp 393 'framework:misspelled-text-color 394 color:misspelled-text-color-style-name 395 (string-constant misspelled-text-color)) 396 397 (let* ([choice (new choice% 398 [label (string-constant parenthesis-color-scheme)] 399 [parent vp] 400 [choices (map (λ (x) (list-ref x 1)) 401 (color:get-parenthesis-colors-table))] 402 [callback 403 (λ (choice _) 404 (preferences:set 'framework:paren-color-scheme 405 (car (list-ref (color:get-parenthesis-colors-table) 406 (send choice get-selection)))))])] 407 [update-choice 408 (lambda (v) 409 (send choice set-string-selection 410 (cadr (or (assoc v (color:get-parenthesis-colors-table)) 411 (car (color:get-parenthesis-colors-table))))))]) 412 (preferences:add-callback 413 'framework:paren-color-scheme 414 (λ (p v) 415 (update-choice v))) 416 (update-choice (preferences:get 'framework:paren-color-scheme))))))) 417 418 (define (build-text-foreground-selection-panel parent pref-sym style-name example-text) 419 (define hp (new-horizontal-panel% 420 (parent parent) 421 (style '(border)) 422 (stretchable-height #f))) 423 (define e (new (class standard-style-list-text% 424 (inherit change-style get-style-list) 425 (define/augment (after-insert pos offset) 426 (inner (void) after-insert pos offset) 427 (let ([style (send (get-style-list) 428 find-named-style 429 style-name)]) 430 (change-style style pos (+ pos offset) #f))) 431 (super-new)))) 432 (define c (new canvas:color% 433 (parent hp) 434 (editor e) 435 (style '(hide-hscroll 436 hide-vscroll)))) 437 (define color-button 438 (and (>= (get-display-depth) 8) 439 (make-object button% 440 (string-constant cs-change-color) 441 hp 442 (λ (color-button evt) 443 (let ([users-choice 444 (get-color-from-user 445 (format (string-constant syntax-coloring-choose-color) example-text) 446 (send color-button get-top-level-window) 447 (lookup-in-color-scheme pref-sym) 448 '(alpha))]) 449 (when users-choice 450 (set-in-color-scheme pref-sym users-choice))))))) 451 (define style (send (send e get-style-list) find-named-style style-name)) 452 453 (send c set-line-count 1) 454 (send c allow-tab-exit #t) 455 456 (send e insert example-text) 457 (send e set-position 0)) 458 459 (define (add-solid-color-config label parent pref-id) 460 (define panel (new-vertical-panel% (parent parent) (stretchable-height #f))) 461 (define hp (new-horizontal-panel% (parent panel) (stretchable-height #f))) 462 (define msg (new message% (parent hp) (label label))) 463 (define canvas 464 (new canvas% 465 (parent hp) 466 (paint-callback 467 (λ (c dc) 468 (draw (lookup-in-color-scheme pref-id)))))) 469 (define (draw clr) 470 (define dc (send canvas get-dc)) 471 (define-values (w h) (send canvas get-client-size)) 472 (send dc set-pen (send the-pen-list find-or-create-pen "black" 1 'transparent)) 473 (send dc set-brush (if (preferences:get 'framework:white-on-black?) 474 "black" 475 "white") 476 'solid) 477 (send dc draw-rectangle 0 0 w h) 478 (send dc set-brush (send the-brush-list find-or-create-brush clr 'solid)) 479 (send dc draw-rectangle 0 0 w h)) 480 (define button 481 (new button% 482 (label (string-constant cs-change-color)) 483 (parent hp) 484 (callback 485 (λ (x y) 486 (define color (get-color-from-user 487 (string-constant choose-a-background-color) 488 (send hp get-top-level-window) 489 (lookup-in-color-scheme pref-id) 490 '(alpha))) 491 (when color 492 (set-in-color-scheme pref-id color)))))) 493 (register-color-scheme-entry-change-callback 494 pref-id 495 (λ (v) 496 ;; the pref should be updated on the next event callback 497 (queue-callback (λ () (send canvas refresh))))) 498 panel) 499 500 ;; add-to-preferences-panel : string (vertical-panel -> void) -> void 501 (define (add-to-preferences-panel panel-name func) 502 (preferences:add-panel 503 (list (string-constant preferences-colors) panel-name) 504 (λ (parent) 505 (let ([panel (new-vertical-panel% (parent parent))]) 506 (func panel) 507 panel)))) 508 509 ;; see docs 510 (define (register-color-preference pref-name style-name color/sd 511 [white-on-black-color #f] 512 [use-old-marshalling? #t] 513 #:background [background #f]) 514 (let ([sd (cond 515 [(is-a? color/sd style-delta%) 516 color/sd] 517 [else 518 (let ([sd (new style-delta%)]) 519 (send sd set-delta-foreground color/sd) 520 sd)])]) 521 522 (when background 523 (send sd set-delta-background background)) 524 525 (preferences:set-default pref-name sd (λ (x) (is-a? x style-delta%))) 526 (when white-on-black-color 527 (set! color-scheme-colors 528 (cons (list pref-name 529 color/sd 530 (to-color white-on-black-color)) 531 color-scheme-colors))) 532 (preferences:set-un/marshall pref-name marshall-style-delta unmarshall-style-delta) 533 (preferences:add-callback pref-name 534 (λ (sym v) 535 (editor:set-standard-style-list-delta style-name v))) 536 (editor:set-standard-style-list-delta style-name (preferences:get pref-name)))) 537 538 (define color-scheme-colors '()) 539 540 (define (set-default/color-scheme pref-sym black-on-white white-on-black) 541 (let ([bw-c (to-color black-on-white)] 542 [wb-c (to-color white-on-black)]) 543 (set! color-scheme-colors 544 (cons (list pref-sym 545 (to-color black-on-white) 546 (to-color white-on-black)) 547 color-scheme-colors)) 548 549 (preferences:set-default pref-sym bw-c (λ (x) (is-a? x color%))) 550 (preferences:set-un/marshall 551 pref-sym 552 (λ (clr) (list (send clr red) (send clr green) (send clr blue) (send clr alpha))) 553 unmarshall-color) 554 (void))) 555 556 (define (unmarshall-color lst) 557 (match lst 558 [(list (? byte? red) (? byte? green) (? byte? blue)) 559 ;; old prefs-- before there were no alpha components to color% objects 560 ;; and so only r/g/b was saved. 561 (make-object color% red green blue)] 562 [(list (? byte? red) (? byte? green) (? byte? blue) (? (between/c 0 1) α)) 563 (make-object color% red green blue α)] 564 [else #f])) 565 566 (define (to-color c) 567 (cond 568 [(is-a? c color%) c] 569 [(is-a? c style-delta%) 570 (let ([m (send c get-foreground-mult)]) 571 (unless (and (= 0 (send m get-r)) 572 (= 0 (send m get-g)) 573 (= 0 (send m get-b))) 574 (error 'register-color-scheme 575 "expected a style delta with foreground-mult that is all zeros")) 576 (let ([add (send c get-foreground-add)]) 577 (make-object color% 578 (send add get-r) 579 (send add get-g) 580 (send add get-b))))] 581 [(string? c) 582 (or (send the-color-database find-color c) 583 (error 'register-color-scheme 584 "did not find color ~s in the-color-database" 585 c))])) 586 587 (define (black-on-white) (do-colorization cadr)) 588 (define (white-on-black) (do-colorization caddr)) 589 (define (do-colorization sel) 590 (for-each (λ (l) 591 (let* ([p (car l)] 592 [color (sel l)] 593 [old (preferences:get p)]) 594 (cond 595 [(is-a? old color%) 596 (preferences:set p color)] 597 [(is-a? old style-delta%) 598 (send old set-delta-foreground color) 599 (preferences:set p old)]))) 600 color-scheme-colors)) 601 602 603 ; 604 ; 605 ; 606 ; 607 ; ;;; ;;; 608 ; ;;; ;;; 609 ; ;;; ;;; ;;; ;;; ;;; ;; ;;;; ;;; ;;; ;; ;;;; ;;; ;; ;;; ;;;; ;;;; 610 ; ;;;;; ;;;;; ;;; ;;;;; ;;;;; ;;; ;; ;;;;; ;;;;;;; ;; ;;; ;;;;;;;;;;; ;; ;;; ;;; ;; 611 ; ;;; ;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; 612 ; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;;; ;;; ;;; ;;; ;;;;;;; ;;; ;;; ;;; ;;;;;;; ;;;; 613 ; ;;; ;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; 614 ; ;;;;; ;;;;; ;;; ;;;;; ;;; ;; ;;; ;;;;; ;;; ;;; ;;;;;; ;;; ;;; ;;; ;;;;;; ;; ;;; 615 ; ;;; ;;; ;;; ;;; ;;; ;;;; ;;; ;;; ;;; ;;;; ;;; ;;; ;;; ;;;; ;;;; 616 ; 617 ; 618 ; 619 ; 620 621 (define default-example 622 (string-append 623 "#lang racket ; draw a graph of\n" 624 "(require plot) ; cos and log\n" 625 "(plot #:label \"y = cos(x) & y = log(x)\"\n" 626 " (list (function cos -5 5) (function log -5 5)))\n" 627 "\"an unclosed string is an error")) 628 629 (struct color-scheme (name button-label white-on-black-base? mapping example) #:transparent) 630 (define black-on-white-color-scheme-name 'classic) 631 (define white-on-black-color-scheme-name 'white-on-black) 632 (define known-color-schemes 633 ;; note:first item in this list must be the black-on-white color scheme 634 ;; and the second must the white-on-black color scheme 635 (list (color-scheme black-on-white-color-scheme-name 636 (string-constant classic-color-scheme) 637 #f (make-hash) default-example) 638 (color-scheme white-on-black-color-scheme-name 639 (string-constant white-on-black-color-scheme) 640 #t (make-hash) default-example))) 641 642 (define color-change-callbacks (make-hash)) 643 644 (define known-color-names (set)) 645 (define known-style-names (set)) 646 647 (define (get-color-scheme-names) (values known-color-names known-style-names)) 648 649 (define-logger color-scheme) 650 651 (define (register-info-based-color-schemes) 652 (log-color-scheme-info 653 "color-names: ~a\nstyle-names:\n~a\n" 654 (sort (set->list known-color-names) symbol<?) 655 (sort (set->list known-style-names) symbol<?)) 656 (define preferred-color-scheme (preferences:get 'framework:color-scheme)) 657 (for ([dir (in-list (find-relevant-directories '(framework:color-schemes)))]) 658 (define info (with-handlers ([exn:fail? 659 (λ (x) 660 (define sp (open-output-string)) 661 (parameterize ([current-error-port sp]) 662 ((error-display-handler) 663 (if (exn? x) (exn-message x) (format "uncaught exn: ~s" x)) 664 x)) 665 (log-color-scheme-warning 666 "info file in ~a failed to load:\n~a" 667 dir 668 (get-output-string sp)) 669 #f)]) 670 (get-info/full dir))) 671 (when info 672 (define cs-info (info 'framework:color-schemes)) 673 (cond 674 [(info-file-result-check? cs-info) 675 (for ([one-scheme (in-list cs-info)]) 676 (define name (hash-ref one-scheme 'name 677 (λ () 678 (define d (path->module-path dir)) 679 (if (path-string? d) 680 (format "~a" d) 681 (format "~s" d))))) 682 (define white-on-black-base? (hash-ref one-scheme 'white-on-black-base? #f)) 683 (define mapping (hash-ref one-scheme 'colors '())) 684 (define example (hash-ref one-scheme 'example default-example)) 685 (register-color-scheme (if (symbol? name) 686 (if (string-constant? name) 687 (dynamic-string-constant name) 688 (symbol->string name)) 689 name) 690 white-on-black-base? 691 mapping 692 example))] 693 [else 694 (when cs-info 695 (log-color-scheme-warning 696 "expected something matching:\n~a\nfor framework:color-schemes in ~a, got\n~a" 697 (pretty-format (contract-name info-file-result-check?)) 698 dir 699 (pretty-format cs-info)))]))) 700 ;; the color-scheme saved in the user's preferences may not be known 701 ;; until after the code above executes, which would mean that the 702 ;; color scheme in effect up to that point may be wrong. So fix that here: 703 (set-current-color-scheme preferred-color-scheme #t)) 704 705 706 ;; register-color-scheme : string boolean? (listof (cons/c symbol? (listof props)) -> void 707 ;; props = (or/c 'bold 'italic 'underline 708 ;; 709 ;; called based on the contents of info.rkt files 710 (define (register-color-scheme scheme-name white-on-black-base? mapping example) 711 (define (good-line? line) 712 (or (set-member? known-color-names (car line)) 713 (set-member? known-style-names (car line)))) 714 (for ([x (in-list mapping)]) 715 (unless (good-line? x) 716 (log-color-scheme-warning "unknown style/color name: ~s" x))) 717 (set! known-color-schemes 718 (append known-color-schemes 719 (list 720 (color-scheme 721 (if (symbol? scheme-name) 722 scheme-name 723 (string->symbol scheme-name)) 724 (if (symbol? scheme-name) 725 (dynamic-string-constant scheme-name) 726 scheme-name) 727 white-on-black-base? 728 (make-hash 729 (for/list ([line (in-list mapping)] 730 #:when (good-line? line)) 731 (define name (car line)) 732 (cons name 733 (cond 734 [(set-member? known-color-names name) 735 (props->color (cdr line))] 736 [(set-member? known-style-names name) 737 (props->style-delta (cdr line))])))) 738 example))))) 739 740 (define color-vector/c 741 (or/c (vector/c byte? byte? byte? #:flat? #t) 742 (vector/c byte? byte? byte? (between/c 0.0 1.0) #:flat? #t))) 743 744 (struct background [color] #:prefab) 745 746 (define background-color/c 747 (struct/c background color-vector/c)) 748 749 (define valid-props? 750 (listof (or/c 'bold 'italic 'underline 751 color-vector/c 752 background-color/c))) 753 754 (define (valid-key-values? h) 755 (for/and ([(k v) (in-hash h)]) 756 (cond 757 [(equal? k 'name) (or (string? v) (symbol? v))] 758 [(equal? k 'white-on-black-base?) (boolean? v)] 759 [(equal? k 'colors) ((listof (cons/c symbol? valid-props?)) v)] 760 [(equal? k 'example) (string? v)] 761 [else 762 ;; don't care about other keys, as they'll be ignored 763 #t]))) 764 765 (define info-file-result-check? 766 (listof (and/c hash? 767 immutable? 768 valid-key-values?))) 769 770 (define (props->color line) 771 (or (for/or ([v (in-list line)]) 772 (and (vector? v) 773 (vec->color v))) 774 (vec->color #(0 0 0)))) 775 776 (define (props->style-delta line) 777 (define sd (new style-delta%)) 778 (for ([prop (in-list line)]) 779 (match prop 780 [`bold (send sd set-delta 'change-bold)] 781 [`italic (send sd set-delta 'change-italic)] 782 [`underline (send sd set-delta 'change-underline #t)] 783 [(? background-color/c) 784 (send sd set-delta-background (vec->color (background-color prop)))] 785 [else (send sd set-delta-foreground (vec->color prop))])) 786 sd) 787 788 (define (vec->color v) 789 (make-object color% 790 (vector-ref v 0) 791 (vector-ref v 1) 792 (vector-ref v 2) 793 (if (= (vector-length v) 4) 794 (vector-ref v 3) 795 1.0))) 796 797 ;; returns the user's preferred color, wrt to the current color scheme 798 (define (lookup-in-color-scheme color-name) 799 (lookup-in-color-scheme/given-mapping 800 color-name 801 (preferences:get (color-scheme-entry-name->pref-name color-name)) 802 (get-current-color-scheme))) 803 804 (define (lookup-in-color-scheme/given-mapping color-name table a-color-scheme) 805 (cond 806 ;; check if the user adjusted the color 807 [(hash-ref table (color-scheme-name a-color-scheme) #f) 808 => 809 values] 810 ;; check if the color scheme has that mapping 811 [(hash-ref (color-scheme-mapping a-color-scheme) 812 color-name 813 #f) 814 => values] 815 [else 816 ;; fall back to either the white-on-black or the black-on-white color scheme 817 (define fallback-color-scheme 818 (lookup-color-scheme 819 (if (color-scheme-white-on-black-base? a-color-scheme) 820 white-on-black-color-scheme-name 821 black-on-white-color-scheme-name))) 822 (hash-ref (color-scheme-mapping fallback-color-scheme) 823 color-name)])) 824 825 ;; set-color : symbol (or/c string? (is-a?/c color%) (is-a?/c style-delta%)) -> void 826 (define (set-in-color-scheme color-name clr/sd) 827 (define table (preferences:get (color-scheme-entry-name->pref-name color-name))) 828 (define current-color-scheme (get-current-color-scheme)) 829 (define scheme-name (color-scheme-name current-color-scheme)) 830 (define new-table 831 (cond 832 [(set-member? known-style-names color-name) 833 ;; it would be good to be able to use hash-remove here when 834 (hash-set table scheme-name clr/sd)] 835 [else 836 (define color (->color-object clr/sd)) 837 (define default 838 (hash-ref (color-scheme-mapping current-color-scheme) 839 color-name 840 #f)) 841 (cond 842 [(and default (same-color? color default)) 843 (hash-remove table scheme-name)] 844 [else 845 (hash-set table scheme-name color)])])) 846 (preferences:set (color-scheme-entry-name->pref-name color-name) new-table)) 847 848 (define (->color-object clr) 849 (if (string? clr) 850 (send the-color-database find-color clr) 851 clr)) 852 853 (define (same-color? c1 c2) 854 (and (= (send c1 red) (send c2 red)) 855 (= (send c1 green) (send c2 green)) 856 (= (send c1 blue) (send c2 blue)) 857 (= (send c1 alpha) (send c2 alpha)))) 858 859 (define (get-current-color-scheme) 860 ;; if pref not recognized, return white-on-black color scheme 861 ;; so that if some color scheme goes away, we have 862 ;; some reasonable backup plan (and, if it comes back 863 ;; we don't lose the prefs) 864 (define pref-val (preferences:get 'framework:color-scheme)) 865 (define found-color-scheme (lookup-color-scheme pref-val)) 866 (cond 867 [found-color-scheme found-color-scheme] 868 [else (car known-color-schemes)])) 869 870 (define (get-current-color-scheme-name) 871 (color-scheme-name (get-current-color-scheme))) 872 873 ;; string -> (or/c #f color-scheme?) 874 (define (lookup-color-scheme name) 875 (for/or ([known-color-scheme (in-list known-color-schemes)]) 876 (and (equal? name (color-scheme-name known-color-scheme)) 877 known-color-scheme))) 878 879 (define (set-current-color-scheme name [avoid-shortcircuit? #f]) 880 (define color-scheme 881 (or (for/or ([known-color-scheme (in-list known-color-schemes)]) 882 (and (equal? name (color-scheme-name known-color-scheme)) 883 known-color-scheme)) 884 (car known-color-schemes))) 885 (when (or avoid-shortcircuit? 886 (not (equal? (color-scheme-name color-scheme) 887 (color-scheme-name (get-current-color-scheme))))) 888 (preferences:set 'framework:color-scheme name) 889 (define old-wob (preferences:get 'framework:white-on-black?)) 890 (define new-wob (color-scheme-white-on-black-base? color-scheme)) 891 (unless (equal? old-wob new-wob) 892 (preferences:set 'framework:white-on-black? new-wob) 893 (if new-wob 894 (white-on-black) 895 (black-on-white))) 896 (for ([(color-name fns) (in-hash color-change-callbacks)]) 897 (for ([fn/b (in-list fns)]) 898 (define fn (if (weak-box? fn/b) (weak-box-value fn/b) fn/b)) 899 (when fn 900 (fn (lookup-in-color-scheme color-name))))))) 901 902 (define (get-available-color-schemes) 903 (for/list ([(name a-color-scheme) (in-hash known-color-schemes)]) 904 name)) 905 906 (define (register-color-scheme-entry-change-callback color fn [weak? #f]) 907 (define wb/f (if weak? (make-weak-box fn) fn)) 908 ;; so we know which callbacks to call when a color scheme change happens 909 (hash-set! color-change-callbacks 910 color 911 (cons wb/f 912 (remove-gones (hash-ref color-change-callbacks color '())))) 913 ;; so that individual color changes in a given scheme get callbacks 914 (define remover 915 (preferences:add-callback 916 (color-scheme-entry-name->pref-name color) 917 (λ (pref ht) 918 (define fn 919 (cond 920 [(weak-box? wb/f) 921 (define fn (weak-box-value wb/f)) 922 (unless fn (remover)) 923 fn] 924 [else wb/f])) 925 (when fn 926 (fn (lookup-in-color-scheme/given-mapping 927 color 928 ht 929 (get-current-color-scheme))))))) 930 (void)) 931 932 (define (remove-gones lst) 933 (for/list ([x (in-list lst)] 934 #:when (or (not (weak-box? x)) 935 (weak-box-value x))) 936 x)) 937 938 (define (known-color-scheme-name? n) 939 (or (set-member? known-color-names n) 940 (set-member? known-style-names n))) 941 942 (define (color-scheme-style-name? n) 943 (set-member? known-style-names n)) 944 945 (define (color-scheme-color-name? n) 946 (set-member? known-color-names n)) 947 948 (define (color-scheme-entry-name->pref-name sym) 949 (string->symbol (format "color-scheme-entry:~a" sym))) 950 951 (define name->style-name (make-hash)) 952 953 (define (add-color-scheme-entry name _b-o-w-color _w-o-b-color 954 #:style [style-name #f] 955 #:bold? [bold 'base] 956 #:underline? [underline? #f] 957 #:italic? [italic? #f] 958 #:background [background #f]) 959 (define b-o-w-color (->color-object _b-o-w-color)) 960 (define w-o-b-color (->color-object _w-o-b-color)) 961 (cond 962 [style-name 963 (set! known-style-names (set-add known-style-names name)) 964 (hash-set! name->style-name name style-name)] 965 [else 966 (set! known-color-names (set-add known-color-names name))]) 967 (define (update-color scheme-name color) 968 (hash-set! (color-scheme-mapping (lookup-color-scheme scheme-name)) 969 name 970 (if style-name 971 (make-style-delta color bold underline? italic? #:background background) 972 color))) 973 (update-color white-on-black-color-scheme-name w-o-b-color) 974 (update-color black-on-white-color-scheme-name b-o-w-color) 975 (preferences:set-default (color-scheme-entry-name->pref-name name) 976 (hash) 977 (hash/c symbol? 978 (if style-name 979 (is-a?/c style-delta%) 980 (is-a?/c color%)) 981 #:immutable #t)) 982 (preferences:set-un/marshall 983 (color-scheme-entry-name->pref-name name) 984 (λ (h) 985 (for/hash ([(k v) (in-hash h)]) 986 (values k 987 (if style-name 988 (marshall-style-delta v) 989 (vector (send v red) (send v green) (send v blue) (send v alpha)))))) 990 (λ (val) 991 (cond 992 [(and (list? val) (= (length val) (length style-delta-get/set))) 993 ;; old style prefs; check to see if this user 994 ;; was using the white on black or black on white and 995 ;; build the corresponding new pref 996 (hash (if (preferences:get 'framework:white-on-black?) 997 white-on-black-color-scheme-name 998 black-on-white-color-scheme-name) 999 (unmarshall-style-delta val))] 1000 [(unmarshall-color val) 1001 => 1002 (λ (clr) 1003 ;; old color prefs; as above 1004 (hash (if (preferences:get 'framework:white-on-black?) 1005 white-on-black-color-scheme-name 1006 black-on-white-color-scheme-name) 1007 clr))] 1008 [(hash? val) 1009 ;; this may return a bogus hash, but the preferesnces system will check 1010 ;; and revert this to the default pref in that case 1011 (for/hash ([(k v) (in-hash val)]) 1012 (values 1013 k 1014 (if style-name 1015 (unmarshall-style-delta v) 1016 (and (vector? v) 1017 (= (vector-length v) 4) 1018 (make-object color% 1019 (vector-ref v 0) (vector-ref v 1) 1020 (vector-ref v 2) (vector-ref v 3))))))] 1021 [else #f]))) 1022 1023 (when style-name 1024 (register-color-scheme-entry-change-callback 1025 name 1026 (λ (sd) 1027 (editor:set-standard-style-list-delta style-name sd))) 1028 (define init-value (lookup-in-color-scheme name)) 1029 (editor:set-standard-style-list-delta style-name init-value))) 1030 1031 (define (add-color-scheme-preferences-panel #:extras [extras void]) 1032 (preferences:add-panel 1033 (list (string-constant preferences-colors) 1034 (string-constant color-schemes)) 1035 (λ (parent) 1036 (define vp 1037 (new-vertical-panel% 1038 [parent parent] 1039 [style '(auto-vscroll)])) 1040 (extras vp) 1041 (define buttons 1042 (for/list ([color-scheme (in-list known-color-schemes)]) 1043 (define hp (new-horizontal-panel% 1044 [parent vp] 1045 [alignment '(left top)] 1046 [stretchable-height #t])) 1047 (define t (new racket:text%)) 1048 (define str (color-scheme-example color-scheme)) 1049 (send t insert str) 1050 (define ec (new editor-canvas% 1051 [parent hp] 1052 [style '(auto-hscroll no-vscroll)] 1053 [editor t])) 1054 (define (update-colors defaults?) 1055 (define bkg-name 'framework:basic-canvas-background) 1056 (send ec set-canvas-background 1057 (lookup-in-color-scheme/given-mapping 1058 bkg-name 1059 (if defaults? 1060 (hash) 1061 (preferences:get (color-scheme-entry-name->pref-name bkg-name))) 1062 color-scheme)) 1063 (send t set-style-list (color-scheme->style-list color-scheme defaults?))) 1064 (send ec set-line-count (+ 1 (for/sum ([c (in-string str)]) 1065 (if (equal? c #\newline) 1066 1 1067 0)))) 1068 (define bp (new-vertical-panel% [parent hp] 1069 [stretchable-height #f] 1070 [stretchable-width #f])) 1071 (define defaults? #f) 1072 (define btn 1073 (new button% 1074 [label (color-scheme-button-label color-scheme)] 1075 [parent bp] 1076 [callback (λ (x y) 1077 (set-current-color-scheme 1078 (color-scheme-name color-scheme)) 1079 (when (and default-checkbox 1080 (send default-checkbox get-value)) 1081 (revert-to-color-scheme-defaults color-scheme)))])) 1082 (define default-checkbox 1083 (new check-box% 1084 [stretchable-width #t] 1085 [label "Revert to\ndefault colors"] 1086 [parent bp] 1087 [callback 1088 (λ (x y) 1089 (update-colors (send default-checkbox get-value)))])) 1090 (update-colors #f) 1091 btn)) 1092 (define wid (apply max (map (λ (x) (send x get-width)) buttons))) 1093 (for ([b (in-list buttons)]) 1094 (send b min-width wid)) 1095 (void)))) 1096 1097 (define (revert-to-color-scheme-defaults color-scheme) 1098 (define cs-name (color-scheme-name color-scheme)) 1099 (for ([name (in-set (set-union known-style-names known-color-names))]) 1100 (define pref-sym (color-scheme-entry-name->pref-name name)) 1101 (define pref-hash (preferences:get pref-sym)) 1102 (when (hash-ref pref-hash cs-name #f) 1103 (preferences:set pref-sym (hash-remove pref-hash cs-name))))) 1104 1105 (define (color-scheme->style-list color-scheme defaults?) 1106 (define style-list (new style-list%)) 1107 1108 (define standard-delta (make-object style-delta% 'change-normal)) 1109 (send standard-delta set-delta 'change-family 'modern) 1110 (send standard-delta set-size-mult 0) 1111 (send standard-delta set-size-add (editor:get-current-preferred-font-size)) 1112 (send standard-delta set-delta-face (preferences:get 'framework:standard-style-list:font-name)) 1113 (send standard-delta set-weight-on (preferences:get 'framework:standard-style-list:weight)) 1114 (send standard-delta set-smoothing-on (preferences:get 'framework:standard-style-list:smoothing)) 1115 (send style-list new-named-style "Standard" 1116 (send style-list find-or-create-style 1117 (send style-list basic-style) 1118 standard-delta)) 1119 (define (update-standard-delta f) 1120 (define delta (make-object style-delta%)) 1121 (define std (send style-list find-named-style "Standard")) 1122 (send std get-delta delta) 1123 (f delta) 1124 (send std set-delta delta)) 1125 (preferences:add-callback 1126 'framework:standard-style-list:weight 1127 (λ (p v) (update-standard-delta (lambda (delta) (send delta set-weight-on v))))) 1128 (preferences:add-callback 1129 'framework:standard-style-list:smoothing 1130 (λ (p v) (update-standard-delta (lambda (delta) (send delta set-smoothing-on v))))) 1131 (for ([name (in-set known-style-names)]) 1132 (define pref-hash (preferences:get (color-scheme-entry-name->pref-name name))) 1133 (define delta 1134 (lookup-in-color-scheme/given-mapping 1135 name 1136 (if defaults? (hash) pref-hash) 1137 color-scheme)) 1138 (send style-list new-named-style 1139 (hash-ref name->style-name name) 1140 (send style-list find-or-create-style 1141 (send style-list find-named-style "Standard") 1142 delta))) 1143 style-list)