fixed PR 7129

svn: r3430

collects/mrlib/syntax-browser.ss

@@ -3,7 +3,6 @@
 needed to really make this work:
 
   - marshallable syntax objects (compile and write out the compiled form)
-  - support for generic ports that are editors
 
 |#
 
@@ -16,6 +15,9 @@ needed to really make this work:
            (lib "string.ss")
 	   "include-bitmap.ss")
 
+  (define orig-output-port (current-output-port))
+  (define (oprintf . args) (apply fprintf orig-output-port args))
+  
   (provide render-syntax/snip render-syntax/window snip-class)
   
   (define (render-syntax/window syntax)
@@ -43,7 +45,7 @@ needed to really make this work:
   (send snip-class set-classname (format "~s" '(lib "syntax-browser.ss" "mrlib")))
   (send (get-the-snip-class-list) add snip-class)
   
-  (define-struct range (obj start end))
+  (define-struct range (stx start end))
 
   (define syntax-snip%
     (class editor-snip%
@@ -58,7 +60,7 @@ needed to really make this work:
       (define/override (write stream)
         (send stream put (string->bytes/utf-8 (format "~s" (marshall-syntax main-stx)))))
       
-      (define-values (datum stx-ht) (syntax-object->datum/ht main-stx))
+      (define-values (datum paths-ht) (syntax-object->datum/record-paths main-stx))
       
       (define output-text (make-object text%))
       (define output-port (make-text-port output-text))
@@ -80,19 +82,72 @@ needed to really make this work:
               0
               (send text last-position)))
       
-      (let ([range-pretty-print-pre-hook 
-             (λ (x v)
-               (hash-table-put! range-start-ht x (send output-text last-position)))]
+      (define path '())
+      (define next-push 0)
+      (define/private (push!)
+        (set! path (cons next-push path))
+        (set! next-push 0))
+      (define/private (pop!)
+        (set! next-push (+ (car path) 1))
+        (set! path (cdr path)))
+      ;; record-paths : val -> hash-table[path -o> syntax-object]
+      (define/private (syntax-object->datum/record-paths val)
+        (set! path '())
+        (set! next-push 0)
+        (let* ([ht (make-hash-table 'equal)]
+               [record
+                (λ (val enclosing-stx)
+                  (hash-table-put! ht path enclosing-stx))])
+          (values
+           (let loop ([val val]
+                      [enclosing-stx #f])
+             (cond
+               [(syntax? val)
+                (loop (syntax-e val)
+                      val)]
+               [(pair? val) 
+                (push!)
+                (record val enclosing-stx)
+                (begin0
+                  (let lst-loop ([val val])
+                    (cond
+                      [(pair? val) 
+                       (cons (loop (car val) #f)
+                             (lst-loop (cdr val)))]
+                      [(null? val) '()]
+                      [else
+                       (loop val enclosing-stx)]))
+                  (pop!))]
+               [else
+                (push!)
+                (record val enclosing-stx)
+                (pop!)
+                val]))
+           ht)))
+      
+      (let* ([range-pretty-print-pre-hook 
+              (λ (x port)
+                (push!)
+                (let ([stx-object (hash-table-get paths-ht path (λ () #f))])
+                  (hash-table-put! range-start-ht stx-object (send output-text last-position))))]
              [range-pretty-print-post-hook 
               (λ (x port)
-               (let ([range-start (hash-table-get range-start-ht x (λ () #f))])
+                (let ([stx-object (hash-table-get paths-ht path (λ () #f))])
+                  (when stx-object
+                    (let ([range-start (hash-table-get range-start-ht stx-object (λ () #f))])
                       (when range-start
-                   (hash-table-put! range-ht x 
+                        (hash-table-put! range-ht 
+                                         stx-object 
                                          (cons
                                           (cons
                                            range-start
                                            (send output-text last-position))
-                                     (hash-table-get range-ht x (λ () null)))))))])
+                                          (hash-table-get range-ht stx-object (λ () null))))))))
+                (pop!))])
+                  
+        ;; reset `path' and `next-push' for use in pp hooks.
+        (set! path '())
+        (set! next-push 0)
         (parameterize ([current-output-port output-port]
                        [pretty-print-pre-print-hook range-pretty-print-pre-hook]
                        [pretty-print-post-print-hook range-pretty-print-post-hook]
@@ -285,8 +340,7 @@ needed to really make this work:
                     (- (range-end y) (range-start y)))))])
         (for-each
          (λ (range)
-           (let* ([obj (range-obj range)]
-                  [stx (hash-table-get stx-ht obj (λ () #f))]
+           (let* ([stx (range-stx range)]
                   [start (range-start range)]
                   [end (range-end range)])
              (when (syntax? stx)
@@ -318,14 +372,9 @@ needed to really make this work:
         
         (send info-text auto-wrap #t)
         (send info-text set-styles-sticky #f)
-        (let/ec k
-          (when (null? ranges)
-            (k (void)))
-          (let* ([rng (car ranges)]
-                 [obj (hash-table-get stx-ht (range-obj rng) 
-                                      (λ ()
-                                        (k (void))))])
-            (show-range obj (range-start rng) (range-end rng)))))
+        (unless (null? ranges)
+          (let ([rng (car ranges)])
+            (show-range (range-stx rng) (range-start rng) (range-end rng)))))
       
       (send output-text hide-caret #t)
       (send info-text hide-caret #t)