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

macro-debugger: fixed image creator

Browse Source 
original commit: e6cf77b61c4f262ea1b7405cfe62557d82da85bb
This commit is contained in:
Ryan Culpepper 2010-11-26 19:09:29 -07:00
parent 6f32f373e9
commit 34f6418e1e
3 changed files with 28 additions and 29 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -5,7 +5,8 @@
framework
"prefs.rkt"
"controller.rkt"
"display.rkt")
"display.rkt"
"text.rkt")
#|
@ -36,12 +37,10 @@ TODO: tacked arrows
;; print-syntax-columns : (parameter-of (U number 'infinity))
(define print-syntax-columns (make-parameter 40))
(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
#:columns [columns (print-syntax-columns)])
(let ([bmp (print-syntax-to-bitmap stx columns)])
(let ([bmp (print-syntax-to-bitmap stx #:columns columns)])
(send bmp save-file file 'png))
(void))
@ -87,7 +86,7 @@ TODO: tacked arrows
(send t print #f #f 'postscript #f #f #t)))
(define (prepare-editor stx columns)
(define t (new standard-text%))
(define t (new browser-text%))
(define sl (send t get-style-list))
(send t change-style (send sl find-named-style (editor:get-default-color-style-name)))
(print-syntax-to-editor stx t

25
collects/macro-debugger/syntax-browser/text.rkt
View File

@ -17,7 +17,8 @@
text:tacking-mixin
text:arrows-mixin
text:region-data-mixin
text:clickregion-mixin)
text:clickregion-mixin
browser-text%)
(define arrow-cursor (make-object cursor% 'arrow))
@ -410,3 +411,25 @@ Like clickbacks, but:
[else (search (cdr idlocs))])))
(super-new)))
|#
(define browser-text%
(let ([browser-text-default-style-name "widget.rkt::browser-text% basic"])
(class (text:clickregion-mixin
(text:arrows-mixin
(text:tacking-mixin
(text:hover-drawings-mixin
(text:hover-mixin
(text:region-data-mixin
(text:hide-caret/selection-mixin
(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))
(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))))

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

@ -247,26 +247,3 @@
(send sd set-delta 'change-italic)
(send sd set-delta-foreground "red")
sd))
;; Specialized classes for widget
(define browser-text%
(let ([browser-text-default-style-name "widget.rkt::browser-text% basic"])
(class (text:clickregion-mixin
(text:arrows-mixin
(text:tacking-mixin
(text:hover-drawings-mixin
(text:hover-mixin
(text:region-data-mixin
(text:hide-caret/selection-mixin
(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))
(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))))