macro-debugger/syntax-browser:

misc code cleanups
  added module for making images

svn: r16925

original commit: 34380bbd1003ed03eb927e48f6f10e66da24fe2c

collects/macro-debugger/syntax-browser/display.ss

@@ -31,63 +31,30 @@
 ;;                       -> 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)

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)

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

collects/macro-debugger/syntax-browser/prefs.ss

@@ -30,15 +30,24 @@
 
     ;; colors : (listof string)
     (define-notify colors
-      (new notify-box%
+      (new notify-box% (value the-colors)))
-           (value '("black" "red" "blue"
+
+    (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"))))
+    "orange" "salmon" "darkgoldenrod" "olive"))
-
-    (super-new)))
 
 (define syntax-prefs-base%
   (class* prefs-base% (config<%>)

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
+;; Use syntax-dummy, and extend pretty-print-remap-stylable to look inside.
-;;     (Symbols are useful: see pretty-print's style table)
+
-;;   - else : map it to a syntax-dummy object
+;; 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))
+             (make-id-syntax-dummy sym sym)
-             (suffix (syntax-e id) n))))))
+             (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)))

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 :
+;; FIXME: Need to disable printing of structs with custom-write property
-;;   syntax port partition (listof string) SuffixOption number
+
+;; 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
+    (syntax->datum/tables stx primary-partition colors suffix-option))
-                          (length 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