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

macro-debugger/syntax-browser:

Browse Source 
misc code cleanups
  added module for making images

svn: r16925

original commit: 34380bbd1003ed03eb927e48f6f10e66da24fe2c
This commit is contained in:
Ryan Culpepper 2009-11-20 19:09:39 +00:00
parent 8927b67dcd
commit 0375e82a2c
6 changed files with 177 additions and 77 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

73
collects/macro-debugger/syntax-browser/display.ss
View File

@ -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)

96
collects/macro-debugger/syntax-browser/image.ss Normal file
View File

@ -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)

1
collects/macro-debugger/syntax-browser/interfaces.ss
View File

@ -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<%>

25
collects/macro-debugger/syntax-browser/prefs.ss
View File

@ -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?)

26
collects/macro-debugger/syntax-browser/pretty-helper.ss
View File

@ -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)))

33
collects/macro-debugger/syntax-browser/pretty-printer.ss
View File

@ -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