www

commit 34f6418e1ea17e88c346e3a5e44c052f821878b6
parent 6f32f373e9506ea880607427e41d58ccde6d1693
Author: Ryan Culpepper <ryanc@racket-lang.org>
Date:   Fri, 26 Nov 2010 19:09:29 -0700

macro-debugger: fixed image creator

original commit: e6cf77b61c4f262ea1b7405cfe62557d82da85bb

Diffstat:
M
collects/macro-debugger/syntax-browser/image.rkt
 | 
9
++++-----
M
collects/macro-debugger/syntax-browser/text.rkt
 | 
25
++++++++++++++++++++++++-
M
collects/macro-debugger/syntax-browser/widget.rkt
 | 
23
-----------------------

3 files changed, 28 insertions(+), 29 deletions(-)
diff --git a/collects/macro-debugger/syntax-browser/image.rkt b/collects/macro-debugger/syntax-browser/image.rkt
@@ -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 
diff --git a/collects/macro-debugger/syntax-browser/text.rkt b/collects/macro-debugger/syntax-browser/text.rkt
@@ -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))))
diff --git a/collects/macro-debugger/syntax-browser/widget.rkt b/collects/macro-debugger/syntax-browser/widget.rkt
@@ -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))))