diff --git a/collects/macro-debugger/syntax-browser/display.ss b/collects/macro-debugger/syntax-browser/display.ss index 2de3c18e93..173419929e 100644 --- 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 new file mode 100644 index 0000000000..d8151c5fdb --- /dev/null +++ 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 index 5b72ce7eb5..d6bc811761 100644 --- 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 index 9f570c57ef..81d1f338ad 100644 --- 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 index 73b22466e9..456eff080e 100644 --- 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 index 12953907a6..f0aa609545 100644 --- 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