macro stepper: cleaned up column-width detection/resizing

svn: r13082

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

@@ -9,34 +9,68 @@
 (provide print-syntax-to-editor
          code-style)
 
-;; print-syntax-to-editor : syntax text controller<%> -> display<%>
-(define (print-syntax-to-editor stx text controller config)
-  (new display% (syntax stx) (text text) (controller controller) (config config)))
-
 ;; FIXME: assumes text never moves
 
+;; print-syntax-to-editor : syntax text controller<%> config number number
+;;                          -> display<%>
+(define (print-syntax-to-editor stx text controller config columns insertion-point)
+  (define output-port (open-output-string/count-lines))
+  (define range
+    (pretty-print-syntax stx output-port 
+                         (send controller get-primary-partition)
+                         (send config get-colors)
+                         (send config get-suffix-option)
+                         columns))
+  (define output-string (get-output-string output-port))
+  (define output-length (sub1 (string-length output-string))) ;; skip final newline
+  (fixup-parentheses output-string range)
+  (let ([display
+         (new display%
+              (text text)
+              (controller controller)
+              (config config)
+              (range range)
+              (start-position insertion-point)
+              (end-position (+ insertion-point output-length)))])
+    (send text begin-edit-sequence)
+    (send text insert output-length output-string insertion-point)
+    (add-clickbacks text range controller insertion-point)
+    (set-standard-font text config insertion-point (+ insertion-point output-length))
+    (send display initialize)
+    (send text end-edit-sequence)
+    display))
+
+;; add-clickbacks : text% range% controller<%> number -> void
+(define (add-clickbacks text range controller insertion-point)
+  (for ([range (send 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 set-selected-syntax stx))))))
+
+;; set-standard-font : text% config number number -> void
+(define (set-standard-font text config start end)
+  (send text change-style
+        (code-style text (send config get-syntax-font-size))
+        start end))
+
 ;; display%
 (define display%
   (class* object% (display<%>)
-    (init ((stx syntax)))
     (init-field text)
     (init-field controller)
     (init-field config)
+    (init-field range)
+    (init-field start-position)
+    (init-field end-position)
 
-    (define start-anchor (new anchor-snip%))
-    (define end-anchor (new anchor-snip%))
-    (define range #f)
     (define extra-styles (make-hasheq))
 
-    ;; render-syntax : syntax -> void
+    ;; initialize : -> void
-    (define/public (render-syntax stx)
+    (define/public (initialize)
-      (with-unlock text
+      (apply-primary-partition-styles)
-        (send text delete (get-start-position) (get-end-position))
-        (set! range
-              (print-syntax stx text controller config
-                            (lambda () (get-start-position))
-                            (lambda () (get-end-position))))
-        (apply-primary-partition-styles))
       (refresh))
 
     ;; refresh : -> void
@@ -45,7 +79,7 @@
       (with-unlock text
         (send* text 
           (begin-edit-sequence)
-          (change-style unhighlight-d (get-start-position) (get-end-position)))
+          (change-style unhighlight-d start-position end-position))
         (apply-extra-styles)
         (let ([selected-syntax (send controller get-selected-syntax)])
           (apply-secondary-partition-styles selected-syntax)
@@ -53,29 +87,15 @@
         (send* text
           (end-edit-sequence))))
 
-    ;; cached-start-position : number
-    (define cached-start-position #f)
-
-    ;; get-start-position : -> number
-    (define/public-final (get-start-position)
-      (unless cached-start-position
-        (set! cached-start-position (send text get-snip-position start-anchor)))
-      cached-start-position)
-
-    ;; get-end-position : -> number
-    (define/public-final (get-end-position)
-      (send text get-snip-position end-anchor))
-
-    ;; relative->text-position : number -> number
-    ;; FIXME: might be slow to find start every time!
-    (define/public-final (relative->text-position pos)
-      (+ pos (get-start-position)))
-
-    ;; Styling
-
     ;; get-range : -> range<%>
     (define/public (get-range) range)
 
+    ;; get-start-position : -> number
+    (define/public (get-start-position) start-position)
+
+    ;; get-end-position : -> number
+    (define/public (get-end-position) end-position)
+
     ;; highlight-syntaxes : (list-of syntax) string -> void
     (define/public (highlight-syntaxes stxs hi-color)
       (let ([style-delta (highlight-style-delta hi-color #f)])
@@ -89,11 +109,50 @@
         (add-extra-styles stx (list underline-style-delta)))
       (refresh))
 
+    ;; add-extra-styles : syntax (listof style) -> void
     (define/public (add-extra-styles stx styles)
       (hash-set! extra-styles stx
                  (append (hash-ref extra-styles stx null)
                          styles)))
 
+    ;; Primary styles
+    ;; (Done once on initialization, never repeated)
+
+    ;; apply-primary-partition-styles : -> void
+    ;; Changes the foreground color according to the primary partition.
+    ;; Only called once, when the syntax is first drawn.
+    (define/private (apply-primary-partition-styles)
+      (define (color-style color)
+        (let ([delta (new style-delta%)])
+          (send delta set-delta-foreground color)
+          delta))
+      (define color-styles (list->vector (map color-style (send config get-colors))))
+      (define overflow-style (color-style "darkgray"))
+      (define color-partition (send controller get-primary-partition))
+      (define offset start-position)
+      (for-each
+       (lambda (range)
+         (let ([stx (range-obj range)]
+               [start (range-start range)]
+               [end (range-end range)])
+           (send text change-style
+                 (primary-style stx color-partition color-styles overflow-style)
+                 (+ offset start)
+                 (+ offset end))))
+       (send range all-ranges)))
+
+    ;; primary-style : syntax partition (vector-of style-delta%) style-delta%
+    ;;               -> style-delta%
+    (define/private (primary-style stx partition color-vector overflow)
+      (let ([n (send partition get-partition stx)])
+        (cond [(< n (vector-length color-vector))
+               (vector-ref color-vector n)]
+              [else
+               overflow])))
+
+    ;; Secondary Styling
+    ;; May change in response to user actions
+
     ;; apply-extra-styles : -> void
     ;; Applies externally-added styles (such as highlighting)
     (define/private (apply-extra-styles)
@@ -131,101 +190,35 @@
             (relative->text-position (car r))
             (relative->text-position (cdr r))))
 
-    ;; Primary styles
+    ;; relative->text-position : number -> number
-
+    (define/private (relative->text-position pos)
-    ;; apply-primary-partition-styles : -> void
+      (+ pos start-position))
-    ;; Changes the foreground color according to the primary partition.
-    ;; Only called once, when the syntax is first drawn.
-    (define/private (apply-primary-partition-styles)
-      (define (color-style color)
-        (let ([delta (new style-delta%)])
-          (send delta set-delta-foreground color)
-          delta))
-      (define color-styles (list->vector (map color-style (send config get-colors))))
-      (define overflow-style (color-style "darkgray"))
-      (define color-partition (send controller get-primary-partition))
-      (define offset (get-start-position))
-      (for-each
-       (lambda (range)
-         (let ([stx (range-obj range)]
-               [start (range-start range)]
-               [end (range-end range)])
-           (send text change-style
-                 (primary-style stx color-partition color-styles overflow-style)
-                 (+ offset start)
-                 (+ offset end))))
-       (send range all-ranges)))
-
-    ;; primary-style : syntax partition (vector-of style-delta%) style-delta%
-    ;;               -> style-delta%
-    (define/private (primary-style stx partition color-vector overflow)
-      (let ([n (send partition get-partition stx)])
-        (cond [(< n (vector-length color-vector))
-               (vector-ref color-vector n)]
-              [else
-               overflow])))
 
     ;; Initialize
     (super-new)
-    (send text insert start-anchor)
-    (send text insert end-anchor)
-    (render-syntax stx)
     (send controller add-syntax-display this)))
 
-;; print-syntax : syntax text% controller config (-> number) (-> number)
+;; fixup-parentheses : string range -> void
-;;                -> range%
+(define (fixup-parentheses string range)
-(define (print-syntax stx text controller config
-                      get-start-position get-end-position)
-  (define primary-partition (send controller get-primary-partition))
-  (define real-output-port (make-text-port text get-end-position))
-  (define output-port (open-output-string))
-  (define colors (send config get-colors))
-  (define suffix-option (send config get-suffix-option))
-  (define columns (send config get-columns))
-
-  (port-count-lines! output-port)
-  (let ([range (pretty-print-syntax stx output-port primary-partition 
-                                    colors suffix-option columns)])
-    (write-string (get-output-string output-port) real-output-port)
-    (let ([end (get-end-position)])
-      ;; Pretty printer always inserts final newline; we remove it here.
-      (send text delete (sub1 end) end))
-    (let ([offset (get-start-position)])
-      (fixup-parentheses text range offset)
-      (for-each
-       (lambda (range)
-         (let* ([stx (range-obj range)]
-                [start (range-start range)]
-                [end (range-end range)])
-           (send text set-clickback (+ offset start) (+ offset end)
-                 (lambda (_1 _2 _3)
-                   (send controller set-selected-syntax stx)))))
-       (send range all-ranges)))
-    ;; Set font to standard
-    (send text change-style
-          (code-style text (send config get-syntax-font-size))
-          (get-start-position)
-          (get-end-position))
-    range))
-
-;; fixup-parentheses : text range -> void
-(define (fixup-parentheses text range offset)
   (define (fixup r)
     (let ([stx (range-obj r)]
-          [start (+ offset (range-start r))]
+          [start (range-start r)]
-          [end (+ offset (range-end r))])
+          [end (range-end r)])
       (when (and (syntax? stx) (pair? (syntax-e stx)))
         (case (syntax-property stx 'paren-shape)
           ((#\[)
-           (replace start #\[)
+           (string-set! string start #\[)
-           (replace (sub1 end) #\]))
+           (string-set! string (sub1 end) #\]))
           ((#\{) 
-           (replace start #\{)
+           (string-set! string start #\{)
-           (replace (sub1 end) #\}))))))
+           (string-set! string (sub1 end) #\}))))))
-  (define (replace pos char)
-    (send text insert char pos (add1 pos)))
   (for-each fixup (send range all-ranges)))
 
+(define (open-output-string/count-lines)
+  (let ([os (open-output-string)])
+    (port-count-lines! os)
+    os))
+
 ;; code-style : text<%> number/#f -> style<%>
 (define (code-style text font-size)
   (let* ([style-list (send text get-style-list)]

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

@@ -22,9 +22,6 @@
 
 (define prefs-base%
   (class object%
-    ;; columns : number
-    (field/notify columns (new notify-box% (value 60)))
-
     ;; suffix-option : SuffixOption
     (field/notify suffix-option (new notify-box% (value 'over-limit)))
 

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

@@ -143,7 +143,7 @@
                 (for ([binder-r (send range get-ranges binder)])
                   (for ([id-r (send range get-ranges id)])
                     (add-binding-arrow start binder-r id-r definite?)))))))
-        display))
+        (void)))
 
     (define/private (add-binding-arrow start binder-r id-r definite?)
       (if definite?
@@ -189,14 +189,17 @@
     ;; internal-add-syntax : syntax -> display
     (define/private (internal-add-syntax stx)
       (with-unlock -text
-        (let ([display (print-syntax-to-editor stx -text controller config)])
+        (let ([display
+               (print-syntax-to-editor stx -text controller config
+                                       (calculate-columns)
+                                       (send -text last-position))])
           (send* -text
             (insert "\n")
             ;;(scroll-to-position current-position)
             )
           display)))
 
-    (define/public (calculate-columns)
+    (define/private (calculate-columns)
       (define style (code-style -text (send config get-syntax-font-size)))
       (define char-width (send style get-text-width (send -ecanvas get-dc)))
       (define-values (canvas-w canvas-h) (send -ecanvas get-client-size))

collects/macro-debugger/view/frame.ss

@@ -54,7 +54,6 @@
     (define/override (on-size w h)
       (send config set-width w)
       (send config set-height h)
-      (send config set-columns (send (send widget get-view) calculate-columns))
       (send widget update/preserve-view))
 
     (define warning-panel