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

changed the macro stepper to be responsive to the white-on-black preference

Browse Source 
(but there is still some work to do to actually select a reasonable set
 of colors and probably some refactoring, but at least the interface with
 the framework is there now, so the changes should not be hard from here on)

original commit: e74e929a9285a47b67a5228dfd1a68280c6b1243
This commit is contained in:
Robby Findler 2010-06-08 10:53:50 -05:00
parent b163abcd46
commit 3219cfd0b6
3 changed files with 51 additions and 26 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

42
collects/macro-debugger/syntax-browser/display.rkt
View File

@ -2,6 +2,7 @@
(require scheme/class
scheme/gui
scheme/list
framework
(rename-in unstable/class-iop
[send/i send:]
[init-field/i init-field:])
@ -106,7 +107,7 @@
(with-unlock text
(send* text
(begin-edit-sequence #f)
(change-style unhighlight-d start-position end-position))
(change-style (unhighlight-d) start-position end-position))
(apply-extra-styles)
(let ([selected-syntax
(send: controller selection-manager<%>
@ -157,7 +158,7 @@
(send delta set-delta-foreground color)
(send style-list find-or-create-style base-style delta)))
(define color-styles
(list->vector (map color-style (send: config config<%> get-colors))))
(list->vector (map color-style (map translate-color (send: config config<%> get-colors)))))
(define overflow-style (color-style "darkgray"))
(define color-partition
(send: controller mark-manager<%> get-primary-partition))
@ -219,7 +220,7 @@
;; draw-secondary-connection : syntax -> void
(define/private (draw-secondary-connection stx2)
(for ([r (send: range range<%> get-ranges stx2)])
(restyle-range r select-sub-highlight-d)))
(restyle-range r (select-sub-highlight-d))))
;; restyle-range : (cons num num) style-delta% -> void
(define/private (restyle-range r style)
@ -258,7 +259,7 @@
;; code-style : text<%> number/#f -> style<%>
(define (code-style text font-size)
(let* ([style-list (send text get-style-list)]
[style (send style-list find-named-style "Standard")])
[style (send style-list find-named-style (editor:get-default-color-style-name))])
(if font-size
(send style-list find-or-create-style
style
@ -274,23 +275,40 @@
;; Styles
(define (highlight-style-delta color em?)
(let ([sd (new style-delta%)])
(unless em? (send sd set-delta-background color))
(define (highlight-style-delta raw-color em? #:translate-color? [translate-color? #t])
(let* ([sd (new style-delta%)])
(unless em? (send sd set-delta-background (if translate-color? (translate-color raw-color) raw-color)))
(when em? (send sd set-weight-on 'bold))
(unless em? (send sd set-underlined-off #t)
(send sd set-weight-off 'bold))
sd))
(define (translate-color color)
(let ([reversed-color
(case (string->symbol (string-downcase color))
[(white) "black"]
[(black) "white"]
[(yellow) "goldenrod"]
[else (printf "unknown color ~s\n" color)
color])])
(if (preferences:get 'framework:white-on-black?)
reversed-color
color)))
(define underline-style-delta
(let ([sd (new style-delta%)])
(send sd set-underlined-on #t)
sd))
(define selection-color "yellow")
(define subselection-color "yellow")
(define (mk-2-constant-style wob-color bow-color)
(let ([wob-version (highlight-style-delta wob-color #f #:translate-color? #f)]
[bow-version (highlight-style-delta bow-color #f #:translate-color? #f)])
(λ ()
(if (preferences:get 'framework:white-on-black?)
wob-version
bow-version))))
(define select-highlight-d (highlight-style-delta selection-color #t))
(define select-sub-highlight-d (highlight-style-delta subselection-color #f))
(define select-highlight-d (mk-2-constant-style "yellow" "darkgoldenrod"))
(define select-sub-highlight-d select-highlight-d) ;; can get rid of this definition(?).
(define unhighlight-d (highlight-style-delta "white" #f))
(define unhighlight-d (mk-2-constant-style "black" "white"))

6
collects/macro-debugger/syntax-browser/image.rkt
View File

@ -36,7 +36,7 @@ TODO: tacked arrows
;; print-syntax-columns : (parameter-of (U number 'infinity))
(define print-syntax-columns (make-parameter 40))
(define standard-text% (editor:standard-style-list-mixin text%))
(define standard-text% (text:foreground-color-mixin (editor:standard-style-list-mixin text:basic%)))
;; print-syntax-to-png : syntax path -> void
(define (print-syntax-to-png stx file
@ -54,7 +54,7 @@ TODO: tacked arrows
(define dc (new bitmap-dc% (bitmap (make-object bitmap% 1 1))))
(define char-width
(let* ([sl (send t get-style-list)]
[style (send sl find-named-style "Standard")]
[style (send sl find-named-style (editor:get-default-color-style-name))]
[font (send style get-font)])
(send dc set-font font)
(send dc get-char-width)))
@ -89,7 +89,7 @@ TODO: tacked arrows
(define (prepare-editor stx columns)
(define t (new standard-text%))
(define sl (send t get-style-list))
(send t change-style (send sl find-named-style "Standard"))
(send t change-style (send sl find-named-style (editor:get-default-color-style-name)))
(print-syntax-to-editor stx t
(new controller%) (new syntax-prefs/readonly%)
columns (send t last-position))

17
collects/macro-debugger/syntax-browser/widget.rkt
View File

@ -33,7 +33,7 @@
(new panel:horizontal-dragable% (parent -main-panel)))
(define -text (new browser-text%))
(define -ecanvas
(new editor-canvas% (parent -split-panel) (editor -text)))
(new canvas:color% (parent -split-panel) (editor -text)))
(define -props-panel (new horizontal-panel% (parent -split-panel)))
(define props
(new properties-view%
@ -251,13 +251,20 @@
;; Specialized classes for widget
(define browser-text%
(let ([browser-text-default-style-name "widget.rkt::browser-text% basic"])
(class (text:arrows-mixin
(text:tacking-mixin
(text:hover-drawings-mixin
(text:hover-mixin
(text:hide-caret/selection-mixin
(editor:standard-style-list-mixin text:basic%))))))
(inherit set-autowrap-bitmap)
(define/override (default-style-name) "Basic")
(text:foreground-color-mixin
(editor:standard-style-list-mixin text:basic%)))))))
(inherit set-autowrap-bitmap get-style-list)
(define/override (default-style-name) browser-text-default-style-name)
(super-new (auto-wrap #t))
(set-autowrap-bitmap #f)))
(let* ([sl (get-style-list)]
[standard (send sl find-named-style (editor:get-default-color-style-name))]
[browser-basic (send sl find-or-create-style standard
(make-object style-delta% 'change-family 'default))])
(send sl new-named-style browser-text-default-style-name browser-basic))
(set-autowrap-bitmap #f))))