suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

more white-on-black colorscheme fixes

Browse Source 
svn: r5906
This commit is contained in:
Robby Findler 2007-04-09 16:26:23 +00:00
parent 30a27b1d8b
commit 35fa233a93
4 changed files with 22 additions and 8 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

23
collects/drscheme/private/debug.ss
View File

@ -66,8 +66,14 @@ profile todo:
(define error-delta (make-object style-delta% 'change-style 'italic)) (define error-delta (make-object style-delta% 'change-style 'italic))
(send error-delta set-delta-foreground (make-object color% 255 0 0)) (send error-delta set-delta-foreground (make-object color% 255 0 0))
;; error-color : (instanceof color%) ;; get-error-color : -> (instanceof color%)
(define error-color (make-object color% "PINK")) (define get-error-color
(let ([w-o-b (make-object color% 63 0 0)]
[b-o-w (make-object color% "PINK")])
(λ ()
(if (preferences:get 'framework:white-on-black?)
w-o-b
b-o-w))))
(define clickable-image-snip% (define clickable-image-snip%
(class image-snip% (class image-snip%
@ -618,10 +624,17 @@ profile todo:
(send context-text hide-caret #t) (send context-text hide-caret #t)
(send text insert " ") (send text insert " ")
(let ([snip (make-object editor-snip% context-text)]) (let ([snip (make-object editor-snip% context-text)])
(send snip use-style-background #t)
(send editor-canvas add-wide-snip snip) (send editor-canvas add-wide-snip snip)
(send text insert snip)) (let ([p (send text last-position)])
(send text insert #\newline)) (send text insert snip p p)
(send text insert #\newline)
(when (preferences:get 'framework:white-on-black?)
(send text change-style white-on-black-style p (+ p 1))))))
(close-text)))) (close-text))))
(define white-on-black-style (make-object style-delta%))
(define stupid-internal-define-syntax1 (send white-on-black-style set-delta-foreground "white"))
;; copy/highlight-text : text number number -> text ;; copy/highlight-text : text number number -> text
;; copies the range from `start' to `finish', including the entire paragraph at ;; copies the range from `start' to `finish', including the entire paragraph at
@ -643,7 +656,7 @@ profile todo:
(< (send from-text get-snip-position snip) para-end-pos)) (< (send from-text get-snip-position snip) para-end-pos))
(send to-text insert (send snip copy)) (send to-text insert (send snip copy))
(loop (send snip next)))) (loop (send snip next))))
(send to-text highlight-range (- from-start 1) from-end error-color #f #f 'high) (send to-text highlight-range (- from-start 1) from-end (get-error-color) #f #f 'high)
to-text)) to-text))
;; get-filename : debug-source -> string ;; get-filename : debug-source -> string

2
collects/drscheme/private/drsig.ss
View File

@ -59,6 +59,8 @@
add-prefs-panel add-prefs-panel
get-error-color
show-error-and-highlight show-error-and-highlight
open-and-highlight-in-file open-and-highlight-in-file
show-backtrace-window show-backtrace-window

3
collects/drscheme/private/rep.ss
View File

@ -495,7 +495,6 @@ TODO
'drscheme:console-previous-exprs 'drscheme:console-previous-exprs
marshall unmarshall)) marshall unmarshall))
(define error-color (make-object color% "PINK"))
(define color? ((get-display-depth) . > . 8)) (define color? ((get-display-depth) . > . 8))
;; instances of this interface provide a context for a rep:text% ;; instances of this interface provide a context for a rep:text%
@ -754,7 +753,7 @@ TODO
[start (- (srcloc-position loc) 1)] [start (- (srcloc-position loc) 1)]
[span (srcloc-span loc)] [span (srcloc-span loc)]
[finish (+ start span)]) [finish (+ start span)])
(send file highlight-range start finish error-color #f #f 'high))) (send file highlight-range start finish (drscheme:debug:get-error-color) #f #f 'high)))
locs)]) locs)])
(when (and definitions-text error-arrows) (when (and definitions-text error-arrows)

2
collects/framework/gui-utils.ss
View File

@ -138,7 +138,7 @@
(define clickback-delta (make-object style-delta% 'change-underline #t)) (define clickback-delta (make-object style-delta% 'change-underline #t))
(define white-on-black-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") (send clickback-delta set-delta-foreground "BLUE")
(send white-on-black-clickback-delta set-delta-foreground "lightblue") (send white-on-black-clickback-delta set-delta-foreground "deepskyblue")
(define get-clickback-delta (define get-clickback-delta
(opt-lambda ([white-on-black? #f]) (opt-lambda ([white-on-black? #f])
(if white-on-black? (if white-on-black?