commit 0375e82a2cddf9536562c5b5a65ea9cdefeda709
parent 8927b67dcd57781a96f2399e5afb276b5db7b295
Author: Ryan Culpepper <ryanc@racket-lang.org>
Date: Fri, 20 Nov 2009 19:09:39 +0000
macro-debugger/syntax-browser:
misc code cleanups
added module for making images
svn: r16925
original commit: 34380bbd1003ed03eb927e48f6f10e66da24fe2c
Diffstat:
6 files changed, 177 insertions(+), 77 deletions(-)
diff --git a/collects/macro-debugger/syntax-browser/display.ss b/collects/macro-debugger/syntax-browser/display.ss
@@ -28,66 +28,33 @@
;; FIXME: assumes text never moves
;; print-syntax-to-editor : syntax text controller<%> config number number
-;; -> display<%>
+;; -> display<%>
(define (print-syntax-to-editor stx text controller config columns insertion-point)
(begin-with-definitions
- (define **entry (now))
(define output-port (open-output-string/count-lines))
(define range
(pretty-print-syntax stx output-port
(send: controller controller<%> get-primary-partition)
- (send: config config<%> get-colors)
+ (length (send: config config<%> get-colors))
(send: config config<%> get-suffix-option)
columns))
- (define **range (now))
(define output-string (get-output-string output-port))
(define output-length (sub1 (string-length output-string))) ;; skip final newline
(fixup-parentheses output-string range)
- (define **fixup (now))
+ (send text begin-edit-sequence #f)
+ (send text insert output-length output-string insertion-point)
(define display
(new display%
(text text)
(controller controller)
(config config)
(range range)
- (base-style (standard-font text config))
(start-position insertion-point)
(end-position (+ insertion-point output-length))))
- (send text begin-edit-sequence #f)
- (define **editing (now))
- (send text insert output-length output-string insertion-point)
- (define **inserted (now))
- (add-clickbacks text range controller insertion-point)
- (define **clickbacks (now))
(send display initialize)
- (define **colorize (now))
(send text end-edit-sequence)
- (define **finished (now))
- (when TIME-PRINTING?
- (eprintf "** pretty-print: ~s\n" (- **range **entry))
- (eprintf "** fixup, begin-edit-sequence: ~s\n" (- **editing **range))
- (eprintf "** > insert: ~s\n" (- **inserted **editing))
- (eprintf "** > clickback: ~s\n" (- **clickbacks **inserted))
- (eprintf "** > colorize: ~s\n" (- **colorize **clickbacks))
- (eprintf "** finish: ~s\n" (- **finished **colorize))
- (eprintf "** total: ~s\n" (- **finished **entry))
- (eprintf "\n"))
display))
-;; add-clickbacks : text% range% controller<%> number -> void
-(define (add-clickbacks text range controller insertion-point)
- (for ([range (send: range range<%> all-ranges)])
- (let ([stx (range-obj range)]
- [start (range-start range)]
- [end (range-end range)])
- (send text set-clickback (+ insertion-point start) (+ insertion-point end)
- (lambda (_1 _2 _3)
- (send: controller selection-manager<%>
- set-selected-syntax stx))))))
-
-(define (standard-font text config)
- (code-style text (send: config config<%> get-syntax-font-size)))
-
;; display%
(define display%
(class* object% (display<%>)
@@ -95,18 +62,48 @@
[config config<%>]
[range range<%>])
(init-field text
- base-style
start-position
end-position)
+ (define base-style
+ (code-style text (send: config config<%> get-syntax-font-size)))
+
(define extra-styles (make-hasheq))
;; initialize : -> void
(define/public (initialize)
(send text change-style base-style start-position end-position #f)
(apply-primary-partition-styles)
+ (add-clickbacks)
(refresh))
+ ;; add-clickbacks : -> void
+ (define/private (add-clickbacks)
+ (define (the-clickback editor start end)
+ (send: controller selection-manager<%> set-selected-syntax
+ (clickback->stx
+ (- start start-position) (- end start-position))))
+ (for ([range (send: range range<%> all-ranges)])
+ (let ([stx (range-obj range)]
+ [start (range-start range)]
+ [end (range-end range)])
+ (send text set-clickback (+ start-position start) (+ start-position end)
+ the-clickback))))
+
+ ;; clickback->stx : num num -> syntax
+ ;; FIXME: use vectors for treerange-subs and do binary search to narrow?
+ (define/private (clickback->stx start end)
+ (let ([treeranges (send: range range<%> get-treeranges)])
+ (let loop* ([treeranges treeranges])
+ (for/or ([tr treeranges])
+ (cond [(and (= (treerange-start tr) start)
+ (= (treerange-end tr) end))
+ (treerange-obj tr)]
+ [(and (<= (treerange-start tr) start)
+ (<= end (treerange-end tr)))
+ (loop* (treerange-subs tr))]
+ [else #f])))))
+
;; refresh : -> void
;; Clears all highlighting and reapplies all non-foreground styles.
(define/public (refresh)
diff --git a/collects/macro-debugger/syntax-browser/image.ss b/collects/macro-debugger/syntax-browser/image.ss
@@ -0,0 +1,96 @@
+#lang scheme/base
+(require scheme/contract
+ scheme/class
+ scheme/gui
+ framework
+ "prefs.ss"
+ "controller.ss"
+ "display.ss")
+
+#|
+
+Code for generating images that look like the contents of a syntax
+browser, with the same pretty-printing, mark-based coloring,
+suffixing, etc.
+
+TODO: tacked arrows
+
+|#
+
+(provide/contract
+ [print-syntax-columns
+ (parameter/c (or/c exact-positive-integer? 'infinity))]
+ [print-syntax-to-png
+ (->* (syntax? path-string?)
+ (#:columns (or/c exact-positive-integer? 'infinity))
+ any)]
+ [print-syntax-to-bitmap
+ (->* (syntax?)
+ (#:columns (or/c exact-positive-integer? 'infinity))
+ (is-a?/c bitmap%))]
+ [print-syntax-to-eps
+ (->* (syntax? path-string?)
+ (#:columns (or/c exact-positive-integer? 'infinity))
+ any)])
+
+;; print-syntax-columns : (parameter-of (U number 'infinity))
+(define print-syntax-columns (make-parameter 40))
+
+(define standard-text% (editor:standard-style-list-mixin text%))
+
+;; 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)])
+ (send bmp save-file file 'png))
+ (void))
+
+;; print-syntax-to-bitmap : syntax -> (is-a?/c bitmap%)
+(define (print-syntax-to-bitmap stx
+ #:columns [columns (print-syntax-columns)])
+ (define t (prepare-editor stx columns))
+ (define f (new frame% [label "dummy"]))
+ (define ec (new editor-canvas% (editor t) (parent f)))
+ (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")]
+ [font (send style get-font)])
+ (send dc set-font font)
+ (send dc get-char-width)))
+ (let ([ew (box 0.0)]
+ [eh (box 0.0)])
+ (send t set-min-width (* columns char-width))
+ (send t get-extent ew eh)
+ (let* ([w (inexact->exact (unbox ew))]
+ [h (inexact->exact (unbox eh))]
+ [bmp (make-object bitmap% w (+ 1 h))]
+ [ps (new ps-setup%)])
+ (send dc set-bitmap bmp)
+ (send dc set-background (make-object color% "White"))
+ (send dc clear)
+ (send ps set-margin 0 0)
+ (send ps set-editor-margin 0 0)
+ (parameterize ((current-ps-setup ps))
+ (send t print-to-dc dc 1))
+ bmp)))
+
+;; print-syntax-to-eps : syntax path -> void
+(define (print-syntax-to-eps stx file
+ #:columns [columns (print-syntax-columns)])
+ (define t (prepare-editor stx columns))
+ (define ps-setup (new ps-setup%))
+ (send ps-setup set-mode 'file)
+ (send ps-setup set-file file)
+ (send ps-setup set-scaling 1 1)
+ (parameterize ((current-ps-setup ps-setup))
+ (send t print #f #f 'postscript #f #f #t)))
+
+(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"))
+ (print-syntax-to-editor stx t
+ (new controller%) (new syntax-prefs/readonly%)
+ columns (send t last-position))
+ t)
diff --git a/collects/macro-debugger/syntax-browser/interfaces.ss b/collects/macro-debugger/syntax-browser/interfaces.ss
@@ -124,6 +124,7 @@
(define-struct range (obj start end))
;; A TreeRange is (make-treerange syntax nat nat (listof TreeRange))
+;; where subs are disjoint, in order, and all contained within [start, end]
(define-struct treerange (obj start end subs))
;; syntax-prefs<%>
diff --git a/collects/macro-debugger/syntax-browser/prefs.ss b/collects/macro-debugger/syntax-browser/prefs.ss
@@ -29,17 +29,26 @@
(define-notify syntax-font-size (new notify-box% (value #f)))
;; colors : (listof string)
- (define-notify colors
- (new notify-box%
- (value '("black" "red" "blue"
- "mediumforestgreen" "darkgreen"
- "darkred"
- "cornflowerblue" "royalblue" "steelblue" "darkslategray" "darkblue"
- "indigo" "purple"
- "orange" "salmon" "darkgoldenrod" "olive"))))
+ (define-notify colors
+ (new notify-box% (value the-colors)))
(super-new)))
+(define alt-colors
+ '("black"
+ "red" "blue" "forestgreen" "purple" "brown"
+ "firebrick" "darkblue" "seagreen" "violetred" "chocolate"
+ "darkred" "cornflowerblue" "darkgreen" "indigo" "sandybrown"
+ "orange" "cadetblue" "olive" "mediumpurple" "goldenrod"))
+
+(define the-colors
+ '("black" "red" "blue"
+ "mediumforestgreen" "darkgreen"
+ "darkred"
+ "cornflowerblue" "royalblue" "steelblue" "darkslategray" "darkblue"
+ "indigo" "purple"
+ "orange" "salmon" "darkgoldenrod" "olive"))
+
(define syntax-prefs-base%
(class* prefs-base% (config<%>)
(init readonly?)
diff --git a/collects/macro-debugger/syntax-browser/pretty-helper.ss b/collects/macro-debugger/syntax-browser/pretty-helper.ss
@@ -14,9 +14,9 @@
;; Solution: Rather than map stx to (syntax-e stx), in the cases where
;; (syntax-e stx) is confusable, map it to a different, unique, value.
-;; - stx is identifier : map it to an uninterned symbol w/ same rep
-;; (Symbols are useful: see pretty-print's style table)
-;; - else : map it to a syntax-dummy object
+;; Use syntax-dummy, and extend pretty-print-remap-stylable to look inside.
+
+;; Old solution: same, except map identifiers to uninterned symbols instead
;; NOTE: Nulls are only wrapped when *not* list-terminators.
;; If they were always wrapped, the pretty-printer would screw up
@@ -35,6 +35,7 @@
(pretty-print datum port)))
(define-struct syntax-dummy (val))
+(define-struct (id-syntax-dummy syntax-dummy) (remap))
;; A SuffixOption is one of
;; - 'never -- never
@@ -58,16 +59,20 @@
;; table : syntax maybe-partition% maybe-num SuffixOption -> (values s-expr hashtable hashtable)
(define (table stx partition limit suffixopt)
(define (make-identifier-proxy id)
+ (define sym (syntax-e id))
(case suffixopt
- ((never) (unintern (syntax-e id)))
+ ((never)
+ (make-id-syntax-dummy sym sym))
((always)
(let ([n (send: partition partition<%> get-partition id)])
- (if (zero? n) (unintern (syntax-e id)) (suffix (syntax-e id) n))))
+ (if (zero? n)
+ (make-id-syntax-dummy sym sym)
+ (make-id-syntax-dummy (suffix sym n) sym))))
((over-limit)
(let ([n (send: partition partition<%> get-partition id)])
(if (<= n limit)
- (unintern (syntax-e id))
- (suffix (syntax-e id) n))))))
+ (make-id-syntax-dummy sym sym)
+ (make-id-syntax-dummy (suffix sym n) sym))))))
(let/ec escape
(let ([flat=>stx (make-hasheq)]
@@ -111,7 +116,7 @@
(refold (map loop fields)))
obj))]
[(symbol? obj)
- (unintern obj)]
+ (make-id-syntax-dummy obj obj)]
[(null? obj)
(make-syntax-dummy obj)]
[(boolean? obj)
@@ -169,8 +174,5 @@
'(quote quasiquote unquote unquote-splicing syntax))
;; FIXME: quasisyntax unsyntax unsyntax-splicing
-(define (unintern sym)
- (string->uninterned-symbol (symbol->string sym)))
-
(define (suffix sym n)
- (string->uninterned-symbol (format "~a:~a" sym n)))
+ (string->symbol (format "~a:~a" sym n)))
diff --git a/collects/macro-debugger/syntax-browser/pretty-printer.ss b/collects/macro-debugger/syntax-browser/pretty-printer.ss
@@ -1,6 +1,3 @@
-
-;; FIXME: Need to disable printing of structs with custom-write property
-
#lang scheme/base
(require scheme/list
scheme/class
@@ -10,15 +7,14 @@
"interfaces.ss")
(provide pretty-print-syntax)
-;; pretty-print-syntax :
-;; syntax port partition (listof string) SuffixOption number
-;; -> range%
+;; FIXME: Need to disable printing of structs with custom-write property
+
+;; pretty-print-syntax : syntax port partition number SuffixOption number
+;; -> range%
(define (pretty-print-syntax stx port primary-partition colors suffix-option columns)
(define range-builder (new range-builder%))
(define-values (datum ht:flat=>stx ht:stx=>flat)
- (syntax->datum/tables stx primary-partition
- (length colors)
- suffix-option))
+ (syntax->datum/tables stx primary-partition colors suffix-option))
(define identifier-list
(filter identifier? (hash-map ht:stx=>flat (lambda (k v) k))))
(define (flat=>stx obj)
@@ -40,13 +36,6 @@
[end (current-position)])
(when (and start stx)
(send range-builder add-range stx (cons start end)))))
- (define (pp-extend-style-table identifier-list)
- (let* ([syms (map (lambda (x) (stx=>flat x)) identifier-list)]
- [like-syms (map syntax-e identifier-list)])
- (pretty-print-extend-style-table (pp-better-style-table)
- syms
- like-syms)))
-
(unless (syntax? stx)
(raise-type-error 'pretty-print-syntax "syntax" stx))
@@ -55,7 +44,8 @@
[pretty-print-post-print-hook pp-post-hook]
[pretty-print-size-hook pp-size-hook]
[pretty-print-print-hook pp-print-hook]
- [pretty-print-current-style-table (pp-extend-style-table identifier-list)]
+ [pretty-print-remap-stylable pp-remap-stylable]
+ [pretty-print-current-style-table (pp-better-style-table)]
[pretty-print-columns columns])
(pretty-print/defaults datum port)
(new range%
@@ -79,9 +69,13 @@
(string-length (get-output-string ostring)))]
[else #f]))
+(define (pp-remap-stylable obj)
+ (and (id-syntax-dummy? obj) (id-syntax-dummy-remap obj)))
+
(define (pp-better-style-table)
(basic-style-list)
- #; ;; Messes up formatting too much :(
+ #|
+ ;; Messes up formatting too much :(
(let* ([pref (pref:tabify)]
[table (car pref)]
[begin-rx (cadr pref)]
@@ -91,7 +85,8 @@
(pretty-print-extend-style-table
(basic-style-list)
(map car style-list)
- (map cdr style-list)))))
+ (map cdr style-list))))
+ |#)
(define (basic-style-list)
(pretty-print-extend-style-table
